[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] emacs etc/NEWS lisp/ChangeLog etc/images/mpc/ad...
|
From: |
Stefan Monnier |
|
Subject: |
[Emacs-diffs] emacs etc/NEWS lisp/ChangeLog etc/images/mpc/ad... |
|
Date: |
Tue, 01 Dec 2009 04:04:39 +0000 |
CVSROOT: /sources/emacs
Module name: emacs
Changes by: Stefan Monnier <monnier> 09/12/01 04:04:38
Modified files:
etc : NEWS
lisp : ChangeLog
Added files:
etc/images/mpc : add.xpm ffwd.xpm next.xpm pause.xpm play.xpm
prev.xpm rewind.xpm stop.xpm
lisp : mpc.el
Log message:
* mpc.el: New file.
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/emacs/etc/NEWS?cvsroot=emacs&r1=1.2131&r2=1.2132
http://cvs.savannah.gnu.org/viewcvs/emacs/etc/images/mpc/add.xpm?cvsroot=emacs&rev=1.1
http://cvs.savannah.gnu.org/viewcvs/emacs/etc/images/mpc/ffwd.xpm?cvsroot=emacs&rev=1.1
http://cvs.savannah.gnu.org/viewcvs/emacs/etc/images/mpc/next.xpm?cvsroot=emacs&rev=1.1
http://cvs.savannah.gnu.org/viewcvs/emacs/etc/images/mpc/pause.xpm?cvsroot=emacs&rev=1.1
http://cvs.savannah.gnu.org/viewcvs/emacs/etc/images/mpc/play.xpm?cvsroot=emacs&rev=1.1
http://cvs.savannah.gnu.org/viewcvs/emacs/etc/images/mpc/prev.xpm?cvsroot=emacs&rev=1.1
http://cvs.savannah.gnu.org/viewcvs/emacs/etc/images/mpc/rewind.xpm?cvsroot=emacs&rev=1.1
http://cvs.savannah.gnu.org/viewcvs/emacs/etc/images/mpc/stop.xpm?cvsroot=emacs&rev=1.1
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/ChangeLog?cvsroot=emacs&r1=1.16781&r2=1.16782
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/mpc.el?cvsroot=emacs&rev=1.1
Patches:
Index: etc/NEWS
===================================================================
RCS file: /sources/emacs/emacs/etc/NEWS,v
retrieving revision 1.2131
retrieving revision 1.2132
diff -u -b -r1.2131 -r1.2132
--- etc/NEWS 30 Nov 2009 19:42:16 -0000 1.2131
+++ etc/NEWS 1 Dec 2009 04:04:33 -0000 1.2132
@@ -323,6 +323,7 @@
* New Modes and Packages in Emacs 23.2
+** mpc.el is a front end for the Music Player Daemon. Run it with M-x mpc.
** htmlfontify.el turns a fontified Emacs buffer into an HTML page.
** FIXME CEDET
Index: lisp/ChangeLog
===================================================================
RCS file: /sources/emacs/emacs/lisp/ChangeLog,v
retrieving revision 1.16781
retrieving revision 1.16782
diff -u -b -r1.16781 -r1.16782
--- lisp/ChangeLog 1 Dec 2009 03:15:01 -0000 1.16781
+++ lisp/ChangeLog 1 Dec 2009 04:04:34 -0000 1.16782
@@ -1,3 +1,7 @@
+2009-12-01 Stefan Monnier <address@hidden>
+
+ * mpc.el: New file.
+
2009-12-01 Glenn Morris <address@hidden>
* window.el (window-to-use): Define for compiler.
Index: etc/images/mpc/add.xpm
===================================================================
RCS file: etc/images/mpc/add.xpm
diff -N etc/images/mpc/add.xpm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ etc/images/mpc/add.xpm 1 Dec 2009 04:04:33 -0000 1.1
@@ -0,0 +1,31 @@
+/* XPM */
+static char * stop_xpm[] = {
+"24 24 4 1",
+" c None",
+". s light1 c grey90",
+"X s main c grey70",
+"o s shadow c grey50",
+" ",
+" ...................... ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXX....XXXXXXXXo ",
+" .XXXXXXXX.XXoXXXXXXXXo ",
+" .XXXXXXXX.XXoXXXXXXXXo ",
+" .XXXXXXXX.XXoXXXXXXXXo ",
+" .XXXXXXXX.XXoXXXXXXXXo ",
+" .XXX......XXo.....XXXo ",
+" .XXX.XXXXXXXXXXXXoXXXo ",
+" .XXX.XXXXXXXXXXXXoXXXo ",
+" .XXX.oooooXXooooooXXXo ",
+" .XXXXXXXX.XXoXXXXXXXXo ",
+" .XXXXXXXX.XXoXXXXXXXXo ",
+" .XXXXXXXX.XXoXXXXXXXXo ",
+" .XXXXXXXX.XXoXXXXXXXXo ",
+" .XXXXXXXX.oooXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .ooooooooooooooooooooo ",
+" "};
Index: etc/images/mpc/ffwd.xpm
===================================================================
RCS file: etc/images/mpc/ffwd.xpm
diff -N etc/images/mpc/ffwd.xpm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ etc/images/mpc/ffwd.xpm 1 Dec 2009 04:04:34 -0000 1.1
@@ -0,0 +1,34 @@
+/* XPM */
+static char * ffwd_xpm[] = {
+"24 24 5 1",
+" c None",
+". s light1 c grey90",
+"X s main c grey70",
+"o s shadow c grey50",
+"O s light2 c grey80",
+" ",
+" ...................... ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXX.OXXX.OXXXXXXXXXXo ",
+" .XXX.XOXX.XOXXXXXXXXXo ",
+" .XXX.XXOO.XXOOXXXXXXXo ",
+" .XXX.XXXX.XXXXOXXXXXXo ",
+" .XXX.XXXX.XXXXXOXXXXXo ",
+" .XXX.XXXX.XXXXXXOOXXXo ",
+" .XXX.XXXX.XXXXXXXXOXXo ",
+" .XXX.XXXX.XXXXXXXXoXXo ",
+" .XXX.XXXX.XXXXXXooXXXo ",
+" .XXX.XXXX.XXXXXoXXXXXo ",
+" .XXX.XXXX.XXXXoXXXXXXo ",
+" .XXX.XXoo.XXooXXXXXXXo ",
+" .XXX.XoXX.XoXXXXXXXXXo ",
+" .XXX.oXXX.oXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .ooooooooooooooooooooo ",
+" "};
+
+/* arch-tag: 9b0fa3cf-1e36-4c20-ac68-948c2ae86b62 */
Index: etc/images/mpc/next.xpm
===================================================================
RCS file: etc/images/mpc/next.xpm
diff -N etc/images/mpc/next.xpm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ etc/images/mpc/next.xpm 1 Dec 2009 04:04:34 -0000 1.1
@@ -0,0 +1,34 @@
+/* XPM */
+static char * next_xpm[] = {
+"24 24 5 1",
+" c None",
+". s light1 c grey90",
+"X s main c grey70",
+"o s shadow c grey50",
+"O s light2 c grey80",
+" ",
+" ...................... ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXX.OXXXXXXXXX...XXXo ",
+" .XXX.XOXXXXXXXX.XoXXXo ",
+" .XXX.XXOOXXXXXX.XoXXXo ",
+" .XXX.XXXXOXXXXX.XoXXXo ",
+" .XXX.XXXXXOXXXX.XoXXXo ",
+" .XXX.XXXXXXOOXX.XoXXXo ",
+" .XXX.XXXXXXXXOX.XoXXXo ",
+" .XXX.XXXXXXXXoX.XoXXXo ",
+" .XXX.XXXXXXooXX.XoXXXo ",
+" .XXX.XXXXXoXXXX.XoXXXo ",
+" .XXX.XXXXoXXXXX.XoXXXo ",
+" .XXX.XXooXXXXXX.XoXXXo ",
+" .XXX.XoXXXXXXXX.XoXXXo ",
+" .XXX.oXXXXXXXXX.ooXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .ooooooooooooooooooooo ",
+" "};
+
+/* arch-tag: 69a2ee4e-e71f-432d-b17b-ac8055dacc93 */
Index: etc/images/mpc/pause.xpm
===================================================================
RCS file: etc/images/mpc/pause.xpm
diff -N etc/images/mpc/pause.xpm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ etc/images/mpc/pause.xpm 1 Dec 2009 04:04:34 -0000 1.1
@@ -0,0 +1,33 @@
+/* XPM */
+static char * pause_xpm[] = {
+"24 24 4 1",
+" c None",
+". s light1 c grey90",
+"X s main c grey70",
+"o s shadow c grey50",
+" ",
+" ...................... ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXX.....XX.....XXXXo ",
+" .XXXX.XXXoXX.XXXoXXXXo ",
+" .XXXX.XXXoXX.XXXoXXXXo ",
+" .XXXX.XXXoXX.XXXoXXXXo ",
+" .XXXX.XXXoXX.XXXoXXXXo ",
+" .XXXX.XXXoXX.XXXoXXXXo ",
+" .XXXX.XXXoXX.XXXoXXXXo ",
+" .XXXX.XXXoXX.XXXoXXXXo ",
+" .XXXX.XXXoXX.XXXoXXXXo ",
+" .XXXX.XXXoXX.XXXoXXXXo ",
+" .XXXX.XXXoXX.XXXoXXXXo ",
+" .XXXX.XXXoXX.XXXoXXXXo ",
+" .XXXX.XXXoXX.XXXoXXXXo ",
+" .XXXX.ooooXX.ooooXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .ooooooooooooooooooooo ",
+" "};
+
+/* arch-tag: 3fe99afb-7dfd-49dd-b5b3-d8eedf14b362 */
Index: etc/images/mpc/play.xpm
===================================================================
RCS file: etc/images/mpc/play.xpm
diff -N etc/images/mpc/play.xpm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ etc/images/mpc/play.xpm 1 Dec 2009 04:04:34 -0000 1.1
@@ -0,0 +1,34 @@
+/* XPM */
+static char * play_xpm[] = {
+"24 24 5 1",
+" c None",
+". s light1 c grey90",
+"X s main c grey70",
+"o s shadow c grey50",
+"O s light2 c grey80",
+" ",
+" ...................... ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXX.OOXXXXXXXXXXXXXXo ",
+" .XXX.XXOOXXXXXXXXXXXXo ",
+" .XXX.XXXXOOXXXXXXXXXXo ",
+" .XXX.XXXXXXOOXXXXXXXXo ",
+" .XXX.XXXXXXXXOOXXXXXXo ",
+" .XXX.XXXXXXXXXXOOXXXXo ",
+" .XXX.XXXXXXXXXXXXOXXXo ",
+" .XXX.XXXXXXXXXXXXoXXXo ",
+" .XXX.XXXXXXXXXXooXXXXo ",
+" .XXX.XXXXXXXXooXXXXXXo ",
+" .XXX.XXXXXXooXXXXXXXXo ",
+" .XXX.XXXXooXXXXXXXXXXo ",
+" .XXX.XXooXXXXXXXXXXXXo ",
+" .XXX.ooXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .ooooooooooooooooooooo ",
+" "};
+
+/* arch-tag: 318eb8de-b126-48bd-818b-bb293df74ec8 */
Index: etc/images/mpc/prev.xpm
===================================================================
RCS file: etc/images/mpc/prev.xpm
diff -N etc/images/mpc/prev.xpm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ etc/images/mpc/prev.xpm 1 Dec 2009 04:04:34 -0000 1.1
@@ -0,0 +1,33 @@
+/* XPM */
+static char * prev_xpm[] = {
+"24 24 4 1",
+" c None",
+". s light1 c grey90",
+"X s main c grey70",
+"o s shadow c grey50",
+" ",
+" ...................... ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXX...XXXXXXXXX..XXXo ",
+" .XXX.XoXXXXXXXX.XoXXXo ",
+" .XXX.XoXXXXXX..XXoXXXo ",
+" .XXX.XoXXXXX.XXXXoXXXo ",
+" .XXX.XoXXXX.XXXXXoXXXo ",
+" .XXX.XoXX..XXXXXXoXXXo ",
+" .XXX.XoX.XXXXXXXXoXXXo ",
+" .XXX.XoXoXXXXXXXXoXXXo ",
+" .XXX.XoXXooXXXXXXoXXXo ",
+" .XXX.XoXXXXoXXXXXoXXXo ",
+" .XXX.XoXXXXXoXXXXoXXXo ",
+" .XXX.XoXXXXXXooXXoXXXo ",
+" .XXX.XoXXXXXXXXoXoXXXo ",
+" .XXX.ooXXXXXXXXXooXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .ooooooooooooooooooooo ",
+" "};
+
+/* arch-tag: 284e0591-6e14-4dae-9cc3-c722fa0b9099 */
Index: etc/images/mpc/rewind.xpm
===================================================================
RCS file: etc/images/mpc/rewind.xpm
diff -N etc/images/mpc/rewind.xpm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ etc/images/mpc/rewind.xpm 1 Dec 2009 04:04:34 -0000 1.1
@@ -0,0 +1,33 @@
+/* XPM */
+static char * rewind_xpm[] = {
+"24 24 4 1",
+" c None",
+". s light1 c grey90",
+"X s main c grey70",
+"o s shadow c grey50",
+" ",
+" ...................... ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXX..XXX..XXXo ",
+" .XXXXXXXXX.XoXX.XoXXXo ",
+" .XXXXXXX..XXo..XXoXXXo ",
+" .XXXXXX.XXXXoXXXXoXXXo ",
+" .XXXXX.XXXXXoXXXXoXXXo ",
+" .XXX..XXXXXXoXXXXoXXXo ",
+" .XX.XXXXXXXXoXXXXoXXXo ",
+" .XXoXXXXXXXXoXXXXoXXXo ",
+" .XXXooXXXXXXoXXXXoXXXo ",
+" .XXXXXoXXXXXoXXXXoXXXo ",
+" .XXXXXXoXXXXoXXXXoXXXo ",
+" .XXXXXXXooXXoooXXoXXXo ",
+" .XXXXXXXXXoXoXXoXoXXXo ",
+" .XXXXXXXXXXooXXXooXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .ooooooooooooooooooooo ",
+" "};
+
+/* arch-tag: 2bdb6c7f-8ddb-4110-b8ee-ffc3f06d1aa9 */
Index: etc/images/mpc/stop.xpm
===================================================================
RCS file: etc/images/mpc/stop.xpm
diff -N etc/images/mpc/stop.xpm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ etc/images/mpc/stop.xpm 1 Dec 2009 04:04:34 -0000 1.1
@@ -0,0 +1,33 @@
+/* XPM */
+static char * stop_xpm[] = {
+"24 24 4 1",
+" c None",
+". s light1 c grey90",
+"X s main c grey70",
+"o s shadow c grey50",
+" ",
+" ...................... ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXX..............XXXo ",
+" .XXX.XXXXXXXXXXXXoXXXo ",
+" .XXX.XXXXXXXXXXXXoXXXo ",
+" .XXX.XXXXXXXXXXXXoXXXo ",
+" .XXX.XXXXXXXXXXXXoXXXo ",
+" .XXX.XXXXXXXXXXXXoXXXo ",
+" .XXX.XXXXXXXXXXXXoXXXo ",
+" .XXX.XXXXXXXXXXXXoXXXo ",
+" .XXX.XXXXXXXXXXXXoXXXo ",
+" .XXX.XXXXXXXXXXXXoXXXo ",
+" .XXX.XXXXXXXXXXXXoXXXo ",
+" .XXX.XXXXXXXXXXXXoXXXo ",
+" .XXX.XXXXXXXXXXXXoXXXo ",
+" .XXX.oooooooooooooXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .XXXXXXXXXXXXXXXXXXXXo ",
+" .ooooooooooooooooooooo ",
+" "};
+
+/* arch-tag: 184ad626-ea69-40ae-839a-f5b5929ebb93 */
Index: lisp/mpc.el
===================================================================
RCS file: lisp/mpc.el
diff -N lisp/mpc.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ lisp/mpc.el 1 Dec 2009 04:04:38 -0000 1.1
@@ -0,0 +1,2601 @@
+;;; mpc.el --- A client for the Music Player Daemon -*- coding: utf-8 -*-
+
+;; Copyright (C) 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <address@hidden>
+;; Keywords: multimedia
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is an Emacs front end to the Music Player Daemon.
+
+;; It mostly provides a browser inspired from Rhythmbox for your music
+;; collection and also allows you to play the music you select. The basic
+;; interface is somewhat unusual in that it does not focus on the
+;; playlist as much as on the browser.
+;; I play albums rather than songs and thus don't have much need for
+;; playlists, and it shows. Playlist support exists, but is still limited.
+
+;; Bugs:
+
+;; - when reaching end/start of song while ffwd/rewind, it may get wedged,
+;; signal an error, ... or when mpc-next/prev is called while ffwd/rewind.
+;; - MPD errors are not reported to the user.
+
+;; Todo:
+
+;; - add bindings/buttons/menuentries for the various commands.
+;; - mpc-undo
+;; - visual feedback for drag'n'drop
+;; - display/set `repeat' and `random' state (and maybe also `crossfade').
+;; - allow multiple *mpc* sessions in the same Emacs to control different mpds.
+;; - look for .folder.png (freedesktop) or folder.jpg (XP) as well.
+;; - fetch album covers and lyrics from the web?
+;; - improve MPC-Status: better volume control, add a way to show/hide the
+;; rest, plus add the buttons currently in the toolbar.
+;; - improve mpc-songs-mode's header-line column-headings so they can be
+;; dragged to resize.
+;; - allow selecting several entries by drag-mouse.
+;; - poll less often
+;; - use the `idle' command
+;; - do the time-ticking locally (and sync every once in a while)
+;; - look at the end of play time to make sure we notice the end
+;; as soon as possible
+;; - better volume widget.
+;; - add synthesized tags.
+;; e.g. pseudo-artist = artist + composer + performer.
+;; e.g. pseudo-performer = performer or artist
+;; e.g. rewrite artist "Foo bar & baz" to "Foo bar".
+;; e.g. filename regexp -> compilation flag
+;; - window/buffer management.
+;; - menubar, tooltips, ...
+;; - add mpc-describe-song, mpc-describe-album, ...
+;; - add import/export commands (especially export to an MP3 player).
+;; - add a real notion of album (as opposed to just album-name):
+;; if all songs with same album-name have same artist -> it's an album
+;; else it's either several albums or a compilation album (or both),
+;; in which case we could use heuristics or user provided info:
+;; - if the user followed the 1-album = 1-dir idea, then we can group songs
+;; by their directory to create albums.
+;; - if a `compilation' flag is available, and if <=1 of the songs have it
+;; set, then we can group songs by their artist to create albums.
+;; - if two songs have the same track-nb and disk-nb, they're not in the
+;; same album. So from the set of songs with identical album names, we
+;; can get a lower bound on the number of albums involved, and then see
+;; which of those may be non-compilations, etc...
+;; - use a special directory name for compilations.
+;; - ask the web ;-)
+
+;;; Code:
+
+;; Prefixes used in this code:
+;; mpc-proc : management of connection (in/out formatting, ...)
+;; mpc-status : auto-updated status info
+;; mpc-volume : stuff handling the volume widget
+;; mpc-cmd : mpdlib abstraction
+
+;; UI-commands : mpc-
+;; internal : mpc--
+
+(eval-when-compile (require 'cl))
+
+;;; Backward compatibility.
+;; This code is meant for Emacs-CVS, so to get it to run on anything else,
+;; we need to define some more things.
+
+(unless (fboundp 'tool-bar-local-item)
+ (defun tool-bar-local-item (icon def key map &rest props)
+ (define-key-after map (vector key)
+ `(menu-item ,(symbol-name key) ,def
+ :image ,(find-image
+ `((:type xpm :file ,(concat icon ".xpm"))))
+ ,@props))))
+
+(unless (fboundp 'process-put)
+ (defconst mpc-process-hash (make-hash-table :weakness 'key))
+ (defun process-put (proc prop val)
+ (let ((sym (gethash proc mpc-process-hash)))
+ (unless sym
+ (setq sym (puthash proc (make-symbol "mpc-proc-sym")
mpc-process-hash)))
+ (put sym prop val)))
+ (defun process-get (proc prop)
+ (let ((sym (gethash proc mpc-process-hash)))
+ (when sym (get sym prop))))
+ (defun process-plist (proc)
+ (let ((sym (gethash proc mpc-process-hash)))
+ (when sym (symbol-plist sym)))))
+(unless (fboundp 'with-local-quit)
+ (defmacro with-local-quit (&rest body)
+ `(condition-case nil (let ((inhibit-quit nil)) ,@body)
+ (quit (setq quit-flag t) nil))))
+(unless (fboundp 'balance-windows-area)
+ (defalias 'balance-windows-area 'balance-windows))
+(unless (fboundp 'posn-object) (defalias 'posn-object 'ignore))
+(unless (fboundp 'buffer-local-value)
+ (defun buffer-local-value (var buf)
+ (with-current-buffer buf (symbol-value var))))
+
+
+;;; Main code starts here.
+
+(defgroup mpc ()
+ "A Client for the Music Player Daemon."
+ :prefix "mpc-"
+ :group 'multimedia
+ :group 'applications)
+
+(defcustom mpc-browser-tags '(Genre Artist Album Playlist)
+ "Tags for which a browser buffer should be created by default."
+ :type '(repeat string))
+
+;;; Misc utils ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun mpc-assq-all (key alist)
+ (let ((res ()) val)
+ (dolist (elem alist)
+ (if (and (eq (car elem) key)
+ (not (member (setq val (cdr elem)) res)))
+ (push val res)))
+ (nreverse res)))
+
+(defun mpc-union (&rest lists)
+ (let ((res (nreverse (pop lists))))
+ (dolist (list lists)
+ (let ((seen res)) ;Don't remove duplicates within each list.
+ (dolist (elem list)
+ (unless (member elem seen) (push elem res)))))
+ (nreverse res)))
+
+(defun mpc-intersection (l1 l2 &optional selectfun)
+ "Return L1 after removing all elements not found in L2.
+SELECTFUN if non-nil elements aren't compared directly, but instead they
+are passed through SELECTFUN before comparison."
+ (let ((res ()))
+ (if selectfun (setq l2 (mapcar selectfun l2)))
+ (dolist (elem l1)
+ (when (member (if selectfun (funcall selectfun elem) elem) l2)
+ (push elem res)))
+ (nreverse res)))
+
+(defun mpc-event-set-point (event)
+ (condition-case nil (posn-set-point (event-end event))
+ (error (condition-case nil (mouse-set-point event)
+ (error nil)))))
+
+(defun mpc-compare-strings (str1 str2 &optional ignore-case)
+ "Compare strings STR1 and STR2.
+Contrary to `compare-strings', this tries to get numbers sorted
+numerically rather than lexicographically."
+ (let ((res (compare-strings str1 nil nil str2 nil nil ignore-case)))
+ (if (not (integerp res)) res
+ (let ((index (1- (abs res))))
+ (if (or (>= index (length str1)) (>= index (length str2)))
+ res
+ (let ((digit1 (memq (aref str1 index)
+ '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))
+ (digit2 (memq (aref str2 index)
+ '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))))
+ (if digit1
+ (if digit2
+ (let ((num1 (progn (string-match "[0-9]+" str1 index)
+ (match-string 0 str1)))
+ (num2 (progn (string-match "[0-9]+" str2 index)
+ (match-string 0 str2))))
+ (cond
+ ;; Here we presume that leading zeroes are only used
+ ;; for same-length numbers. So we'll incorrectly
+ ;; consider that "000" comes after "01", but I don't
+ ;; think it matters.
+ ((< (length num1) (length num2)) (- (abs res)))
+ ((> (length num1) (length num2)) (abs res))
+ ((< (string-to-number num1) (string-to-number num2))
+ (- (abs res)))
+ (t (abs res))))
+ ;; "1a" comes before "10", but "0" comes before "a".
+ (if (and (not (zerop index))
+ (memq (aref str1 (1- index))
+ '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))
+ (abs res)
+ (- (abs res))))
+ (if digit2
+ ;; "1a" comes before "10", but "0" comes before "a".
+ (if (and (not (zerop index))
+ (memq (aref str1 (1- index))
+ '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))
+ (- (abs res))
+ (abs res))
+ res))))))))
+
+(defun mpc-string-prefix-p (str1 str2)
+ ;; FIXME: copied from pcvs-util.el.
+ "Tell whether STR1 is a prefix of STR2."
+ (eq t (compare-strings str2 nil (length str1) str1 nil nil)))
+
+;; This can speed up mpc--song-search significantly. The table may grow
+;; very large, tho. It's only bounded by the fact that it gets flushed
+;; whenever the connection is established; which seems to work OK thanks
+;; to the fact that MPD tends to disconnect fairly often, although our
+;; constant polling often prevents disconnection.
+(defvar mpc--find-memoize (make-hash-table :test 'equal)) ;; :weakness t
+(defvar mpc-tag nil) (make-variable-buffer-local 'mpc-tag)
+
+;;; Support for the actual connection and MPD command execution ;;;;;;;;;;;;
+
+(defcustom mpc-host
+ (concat (or (getenv "MPD_HOST") "localhost")
+ (if (getenv "MPD_PORT") (concat ":" (getenv "MPD_PORT"))))
+ "Host (and port) where the Music Player Daemon is running.
+The format is \"HOST\" or \"HOST:PORT\" where PORT defaults to 6600
+and HOST default to localhost."
+ :type 'string)
+
+(defvar mpc-proc nil)
+
+(defconst mpc--proc-end-re "^\\(?:OK\\(?: MPD .*\\)?\\|ACK \\(.*\\)\\)\n")
+
+(put 'mpc-proc-error 'error-conditions '(mpc-proc-error error))
+(put 'mpc-proc-error 'error-message "MPD error")
+
+(defun mpc--debug (format &rest args)
+ (if (get-buffer "*MPC-debug*")
+ (with-current-buffer "*MPC-debug*"
+ (goto-char (point-max))
+ (insert-before-markers ;So it scrolls.
+ (replace-regexp-in-string "\n" "\n "
+ (apply 'format format args))
+ "\n"))))
+
+(defun mpc--proc-filter (proc string)
+ (mpc--debug "Receive \"%s\"" string)
+ (with-current-buffer (process-buffer proc)
+ (if (process-get proc 'ready)
+ (if nil ;; (string-match "\\`\\(OK\n\\)+\\'" string)
+ ;; I haven't figured out yet why I get those extraneous OKs,
+ ;; so I'll just ignore them for now.
+ nil
+ (delete-process proc)
+ (set-process-buffer proc nil)
+ (pop-to-buffer (clone-buffer))
+ (error "MPD output while idle!?"))
+ (save-excursion
+ (let ((start (or (marker-position (process-mark proc)) (point-min))))
+ (goto-char start)
+ (insert string)
+ (move-marker (process-mark proc) (point))
+ (beginning-of-line)
+ (when (and (< start (point))
+ (re-search-backward mpc--proc-end-re start t))
+ (process-put proc 'ready t)
+ (unless (eq (match-end 0) (point-max))
+ (error "Unexpected trailing text"))
+ (let ((error (match-string 1)))
+ (delete-region (point) (point-max))
+ (let ((callback (process-get proc 'callback)))
+ (process-put proc 'callback nil)
+ (if error (signal 'mpc-proc-error error))
+ (funcall callback)))))))))
+
+(defun mpc--proc-connect (host)
+ (mpc--debug "Connecting to %s..." host)
+ (with-current-buffer (get-buffer-create (format " *mpc-%s*" host))
+ ;; (pop-to-buffer (current-buffer))
+ (let (proc)
+ (while (and (setq proc (get-buffer-process (current-buffer)))
+ (progn ;; (debug)
+ (delete-process proc)))))
+ (erase-buffer)
+ (let ((port 6600))
+ (when (string-match ":[^.]+\\'" host)
+ (setq port (substring host (1+ (match-beginning 0))))
+ (setq host (substring host 0 (match-beginning 0)))
+ (unless (string-match "[^[:digit:]]" port)
+ (setq port (string-to-number port))))
+ (let* ((coding-system-for-read 'utf-8-unix)
+ (coding-system-for-write 'utf-8-unix)
+ (proc (open-network-stream "MPC" (current-buffer) host port)))
+ (when (processp mpc-proc)
+ ;; Inherit the properties of the previous connection.
+ (let ((plist (process-plist mpc-proc)))
+ (while plist (process-put proc (pop plist) (pop plist)))))
+ (mpc-proc-buffer proc 'mpd-commands (current-buffer))
+ (process-put proc 'callback 'ignore)
+ (process-put proc 'ready nil)
+ (clrhash mpc--find-memoize)
+ (set-process-filter proc 'mpc--proc-filter)
+ (set-process-sentinel proc 'ignore)
+ (set-process-query-on-exit-flag proc nil)
+ ;; This may be called within a process filter ;-(
+ (with-local-quit (mpc-proc-sync proc))
+ proc))))
+
+(defun mpc--proc-quote-string (s)
+ (if (numberp s) (number-to-string s)
+ (setq s (replace-regexp-in-string "[\"\\]" "\\\\\\&" s))
+ (if (string-match " " s) (concat "\"" s "\"") s)))
+
+(defconst mpc--proc-alist-to-alists-starters '(file directory))
+
+(defun mpc--proc-alist-to-alists (alist)
+ (assert (or (null alist)
+ (memq (caar alist) mpc--proc-alist-to-alists-starters)))
+ (let ((starter (caar alist))
+ (alists ())
+ tmp)
+ (dolist (pair alist)
+ (when (eq (car pair) starter)
+ (if tmp (push (nreverse tmp) alists))
+ (setq tmp ()))
+ (push pair tmp))
+ (if tmp (push (nreverse tmp) alists))
+ (nreverse alists)))
+
+(defun mpc-proc ()
+ (or (and mpc-proc
+ (buffer-live-p (process-buffer mpc-proc))
+ (not (memq (process-status mpc-proc) '(closed)))
+ mpc-proc)
+ (setq mpc-proc (mpc--proc-connect mpc-host))))
+
+(defun mpc-proc-sync (&optional proc)
+ "Wait for MPC process until it is idle again.
+Return the buffer in which the process is/was running."
+ (unless proc (setq proc (mpc-proc)))
+ (unwind-protect
+ (condition-case err
+ (progn
+ (while (and (not (process-get proc 'ready))
+ (accept-process-output proc)))
+ (if (process-get proc 'ready) (process-buffer proc)
+ ;; (delete-process proc)
+ (error "No response from MPD")))
+ (error (message "MPC: %s" err) (signal (car err) (cdr err))))
+ (unless (process-get proc 'ready)
+ ;; (debug)
+ (message "Killing hung process")
+ (delete-process proc))))
+
+(defun mpc-proc-cmd (cmd &optional callback)
+ "Send command CMD to the MPD server.
+If CALLBACK is nil, wait for the command to finish before returning,
+otherwise return immediately and call CALLBACK with no argument
+when the command terminates.
+CMD can be a string which is passed as-is to MPD or a list of strings
+which will be concatenated with proper quoting before passing them to MPD."
+ (let ((proc (mpc-proc)))
+ (if (and callback (not (process-get proc 'ready)))
+ (lexical-let ((old (process-get proc 'callback))
+ (callback callback)
+ (cmd cmd))
+ (process-put proc 'callback
+ (lambda ()
+ (funcall old)
+ (mpc-proc-cmd cmd callback))))
+ ;; Wait for any pending async command to terminate.
+ (mpc-proc-sync proc)
+ (process-put proc 'ready nil)
+ (with-current-buffer (process-buffer proc)
+ (erase-buffer)
+ (mpc--debug "Send \"%s\"" cmd)
+ (process-send-string
+ proc (concat (if (stringp cmd) cmd
+ (mapconcat 'mpc--proc-quote-string cmd " "))
+ "\n")))
+ (if callback
+ (lexical-let ((buf (current-buffer))
+ (callback callback))
+ (process-put proc 'callback
+ callback
+ ;; (lambda ()
+ ;; (funcall callback
+ ;; (prog1 (current-buffer)
+ ;; (set-buffer buf))))
+ ))
+ ;; If `callback' is nil, we're executing synchronously.
+ (process-put proc 'callback 'ignore)
+ ;; This returns the process's buffer.
+ (mpc-proc-sync proc)))))
+
+;; This function doesn't exist in Emacs-21.
+;; (put 'mpc-proc-cmd-list 'byte-optimizer 'byte-optimize-pure-func)
+(defun mpc-proc-cmd-list (cmds)
+ (concat "command_list_begin\n"
+ (mapconcat (lambda (cmd)
+ (if (stringp cmd) cmd
+ (mapconcat 'mpc--proc-quote-string cmd " ")))
+ cmds
+ "\n")
+ "\ncommand_list_end"))
+
+(defun mpc-proc-cmd-list-ok ()
+ ;; To implement this, we'll need to tweak the process filter since we'd
+ ;; then sometimes get "trailing" text after "OK\n".
+ (error "Not implemented yet"))
+
+(defun mpc-proc-buf-to-alist (&optional buf)
+ (with-current-buffer (or buf (current-buffer))
+ (let ((res ()))
+ (goto-char (point-min))
+ (while (re-search-forward "^\\([^:]+\\): \\(.*\\)\n" nil t)
+ (push (cons (intern (match-string 1)) (match-string 2)) res))
+ (nreverse res))))
+
+(defun mpc-proc-buf-to-alists (buf)
+ (mpc--proc-alist-to-alists (mpc-proc-buf-to-alist buf)))
+
+(defun mpc-proc-cmd-to-alist (cmd &optional callback)
+ (if callback
+ (lexical-let ((buf (current-buffer))
+ (callback callback))
+ (mpc-proc-cmd cmd (lambda ()
+ (funcall callback (prog1 (mpc-proc-buf-to-alist
+ (current-buffer))
+ (set-buffer buf))))))
+ ;; (lexical-let ((res nil))
+ ;; (mpc-proc-cmd-to-alist cmd (lambda (alist) (setq res alist)))
+ ;; (mpc-proc-sync)
+ ;; res)
+ (mpc-proc-buf-to-alist (mpc-proc-cmd cmd))))
+
+(defun mpc-proc-tag-string-to-sym (tag)
+ (intern (capitalize tag)))
+
+(defun mpc-proc-buffer (proc use &optional buffer)
+ (let* ((bufs (process-get proc 'buffers))
+ (buf (cdr (assoc use bufs))))
+ (cond
+ ((and buffer (buffer-live-p buf) (not (eq buffer buf)))
+ (error "Duplicate MPC buffer for %s" use))
+ (buffer
+ (if buf
+ (setcdr (assoc use bufs) buffer)
+ (process-put proc 'buffers (cons (cons use buffer) bufs))))
+ (t buf))))
+
+;;; Support for regularly updated current status information ;;;;;;;;;;;;;;;
+
+;; Exported elements:
+;; `mpc-status' holds the uptodate data.
+;; `mpc-status-callbacks' holds the registered callback functions.
+;; `mpc-status-refresh' forces a refresh of the data.
+;; `mpc-status-stop' stops the automatic updating.
+
+(defvar mpc-status nil)
+(defvar mpc-status-callbacks
+ '((state . mpc--status-timers-refresh)
+ ;; (song . mpc--queue-refresh)
+ ;; (state . mpc--queue-refresh) ;To detect the end of the last song.
+ (state . mpc--faster-toggle-refresh) ;Only ffwd/rewind while play/pause.
+ (volume . mpc-volume-refresh)
+ (file . mpc-songpointer-refresh)
+ ;; The song pointer may need updating even if the file doesn't change,
+ ;; if the same song appears multiple times in a row.
+ (song . mpc-songpointer-refresh)
+ (updating_db . mpc-updated-db)
+ (updating_db . mpc--status-timers-refresh)
+ (t . mpc-current-refresh))
+ "Alist associating properties to the functions that care about them.
+Each entry has the form (PROP . FUN) where PROP can be t to mean
+to call FUN for any change whatsoever.")
+
+(defun mpc--status-callback ()
+ (let ((old-status mpc-status))
+ ;; Update the alist.
+ (setq mpc-status (mpc-proc-buf-to-alist))
+ (assert mpc-status)
+ (unless (equal old-status mpc-status)
+ ;; Run the relevant refresher functions.
+ (dolist (pair mpc-status-callbacks)
+ (when (or (eq t (car pair))
+ (not (equal (cdr (assq (car pair) old-status))
+ (cdr (assq (car pair) mpc-status)))))
+ (funcall (cdr pair)))))))
+
+(defvar mpc--status-timer nil)
+(defun mpc--status-timer-start ()
+ (add-hook 'pre-command-hook 'mpc--status-timer-stop)
+ (unless mpc--status-timer
+ (setq mpc--status-timer (run-with-timer 1 1 'mpc--status-timer-run))))
+(defun mpc--status-timer-stop ()
+ (when mpc--status-timer
+ (cancel-timer mpc--status-timer)
+ (setq mpc--status-timer nil)))
+(defun mpc--status-timer-run ()
+ (when (process-get (mpc-proc) 'ready)
+ (condition-case err
+ (with-local-quit (mpc-status-refresh))
+ (error (message "MPC: %s" err)))))
+
+(defvar mpc--status-idle-timer nil)
+(defun mpc--status-idle-timer-start ()
+ (when mpc--status-idle-timer
+ ;; Turn it off even if we'll start it again, in case it changes the delay.
+ (cancel-timer mpc--status-idle-timer))
+ (setq mpc--status-idle-timer
+ (run-with-idle-timer 1 t 'mpc--status-idle-timer-run))
+ ;; Typically, the idle timer is started from the mpc--status-callback,
+ ;; which is run asynchronously while we're already idle (we typically
+ ;; just started idling), so the timer itself will only be run the next
+ ;; time we idle :-(
+ ;; To work around that, we immediately start the repeat timer.
+ (mpc--status-timer-start))
+(defun mpc--status-idle-timer-stop (&optional really)
+ (when mpc--status-idle-timer
+ ;; Turn it off even if we'll start it again, in case it changes the delay.
+ (cancel-timer mpc--status-idle-timer))
+ (setq mpc--status-idle-timer
+ (unless really
+ ;; We don't completely stop the timer, so that if some other MPD
+ ;; client starts playback, we may get a chance to notice it.
+ (run-with-idle-timer 10 t 'mpc--status-idle-timer-run))))
+(defun mpc--status-idle-timer-run ()
+ (when (process-get (mpc-proc) 'ready)
+ (condition-case err
+ (with-local-quit (mpc-status-refresh))
+ (error (message "MPC: %s" err))))
+ (mpc--status-timer-start))
+
+(defun mpc--status-timers-refresh ()
+ "Start/stop the timers according to whether a song is playing."
+ (if (or (member (cdr (assq 'state mpc-status)) '("play"))
+ (cdr (assq 'updating_db mpc-status)))
+ (mpc--status-idle-timer-start)
+ (mpc--status-idle-timer-stop)
+ (mpc--status-timer-stop)))
+
+(defun mpc-status-refresh (&optional callback)
+ "Refresh `mpc-status'."
+ (lexical-let ((cb callback))
+ (mpc-proc-cmd (mpc-proc-cmd-list '("status" "currentsong"))
+ (lambda ()
+ (mpc--status-callback)
+ (if cb (funcall cb))))))
+
+(defun mpc-status-stop ()
+ "Stop the autorefresh of `mpc-status'.
+This is normally used only when quitting MPC.
+Any call to `mpc-status-refresh' may cause it to be restarted."
+ (setq mpc-status nil)
+ (mpc--status-idle-timer-stop 'really)
+ (mpc--status-timer-stop))
+
+;;; A thin layer above the raw protocol commands ;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; (defvar mpc-queue nil)
+;; (defvar mpc-queue-back nil)
+
+;; (defun mpc--queue-head ()
+;; (if (stringp (car mpc-queue)) (car mpc-queue) (cadar mpc-queue)))
+;; (defun mpc--queue-pop ()
+;; (when mpc-queue ;Can be nil if out of sync.
+;; (let ((song (car mpc-queue)))
+;; (assert song)
+;; (push (if (and (consp song) (cddr song))
+;; ;; The queue's first element is itself a list of
+;; ;; songs, where the first element isn't itself a song
+;; ;; but a description of the list.
+;; (prog1 (cadr song) (setcdr song (cddr song)))
+;; (prog1 (if (consp song) (cadr song) song)
+;; (setq mpc-queue (cdr mpc-queue))))
+;; mpc-queue-back)
+;; (assert (stringp (car mpc-queue-back))))))
+
+;; (defun mpc--queue-refresh ()
+;; ;; Maintain the queue.
+;; (mpc--debug "mpc--queue-refresh")
+;; (let ((pos (cdr (or (assq 'Pos mpc-status) (assq 'song mpc-status)))))
+;; (cond
+;; ((null pos)
+;; (mpc-cmd-clear 'ignore))
+;; ((or (not (member pos '("0" nil)))
+;; ;; There's only one song in the playlist and we've stopped.
+;; ;; Maybe it's because of some external client that set the
+;; ;; playlist like that and/or manually stopped the playback, but
+;; ;; it's more likely that we've simply reached the end of
+;; ;; the song. So remove it.
+;; (and (equal (assq 'state mpc-status) "stop")
+;; (equal (assq 'playlistlength mpc-status) "1")
+;; (setq pos "1")))
+;; ;; We're not playing the first song in the queue/playlist any
+;; ;; more, so update the queue.
+;; (dotimes (i (string-to-number pos)) (mpc--queue-pop))
+;; (mpc-proc-cmd (mpc-proc-cmd-list
+;; (make-list (string-to-number pos) "delete 0"))
+;; 'ignore)
+;; (if (not (equal (cdr (assq 'file mpc-status))
+;; (mpc--queue-head)))
+;; (message "MPC's queue is out of sync"))))))
+
+(defun mpc-cmd-find (tag value)
+ "Return a list of all songs whose tag TAG has value VALUE.
+The songs are returned as alists."
+ (or (gethash (cons tag value) mpc--find-memoize)
+ (puthash (cons tag value)
+ (cond
+ ((eq tag 'Playlist)
+ ;; Special case for pseudo-tag playlist.
+ (let ((l (mpc-proc-buf-to-alists
+ (mpc-proc-cmd (list "listplaylistinfo" value))))
+ (i 0))
+ (mapcar (lambda (s)
+ (prog1 (cons (cons 'Pos (number-to-string i)) s)
+ (incf i)))
+ l)))
+ ((eq tag 'Search)
+ (mpc-proc-buf-to-alists
+ (mpc-proc-cmd (list "search" "any" value))))
+ ((eq tag 'Directory)
+ (let ((pairs
+ (mpc-proc-buf-to-alist
+ (mpc-proc-cmd (list "listallinfo" value)))))
+ (mpc--proc-alist-to-alists
+ ;; Strip away the `directory' entries.
+ (delq nil (mapcar (lambda (pair)
+ (if (eq (car pair) 'directory)
+ nil pair))
+ pairs)))))
+ (t
+ (condition-case err
+ (mpc-proc-buf-to-alists
+ (mpc-proc-cmd (list "find" (symbol-name tag) value)))
+ (mpc-proc-error
+ ;; If `tag' is not one of the expected tags, MPD burps
+ ;; about not having the relevant table. FIXME: check
+ ;; the kind of error.
+ (error "Unknown tag %s" tag)
+ (let ((res ()))
+ (setq value (cons tag value))
+ (dolist (song (mpc-proc-buf-to-alists
+ (mpc-proc-cmd "listallinfo")))
+ (if (member value song) (push song res)))
+ res)))))
+ mpc--find-memoize)))
+
+(defun mpc-cmd-list (tag &optional other-tag value)
+ ;; FIXME: we could also provide a `mpc-cmd-list' alternative which
+ ;; doesn't take an "other-tag value" constraint but a "song-list" instead.
+ ;; That might be more efficient in some cases.
+ (cond
+ ((eq tag 'Playlist)
+ (let ((pls (mpc-assq-all 'playlist (mpc-proc-cmd-to-alist "lsinfo"))))
+ (when other-tag
+ (dolist (pl (prog1 pls (setq pls nil)))
+ (let ((plsongs (mpc-cmd-find 'Playlist pl)))
+ (if (not (member other-tag '(Playlist Search Directory)))
+ (when (member (cons other-tag value)
+ (apply 'append plsongs))
+ (push pl pls))
+ ;; Problem N°2: we compute the intersection whereas all
+ ;; we care about is whether it's empty. So we could
+ ;; speed this up significantly.
+ ;; We only compare file names, because the full song-entries
+ ;; are slightly different (the ones in plsongs include
+ ;; position and id info specific to the playlist), and it's
+ ;; good enough because this is only used with "search", which
+ ;; doesn't pay attention to playlists and URLs anyway.
+ (let* ((osongs (mpc-cmd-find other-tag value))
+ (ofiles (mpc-assq-all 'file (apply 'append osongs)))
+ (plfiles (mpc-assq-all 'file (apply 'append plsongs))))
+ (when (mpc-intersection plfiles ofiles)
+ (push pl pls)))))))
+ pls))
+
+ ((eq tag 'Directory)
+ (if (null other-tag)
+ (apply 'nconc
+ (mpc-assq-all 'directory
+ (mpc-proc-buf-to-alist
+ (mpc-proc-cmd "lsinfo")))
+ (mapcar (lambda (dir)
+ (let ((shortdir
+ (if (get-text-property 0 'display dir)
+ (concat " "
+ (get-text-property 0 'display dir))
+ " ⪠"))
+ (subdirs
+ (mpc-assq-all 'directory
+ (mpc-proc-buf-to-alist
+ (mpc-proc-cmd (list "lsinfo"
dir))))))
+ (dolist (subdir subdirs)
+ (put-text-property 0 (1+ (length dir))
+ 'display shortdir
+ subdir))
+ subdirs))
+ (process-get (mpc-proc) 'Directory)))
+ ;; If there's an other-tag, then just extract the dir info from the
+ ;; list of other-tag's songs.
+ (let* ((other-songs (mpc-cmd-find other-tag value))
+ (files (mpc-assq-all 'file (apply 'append other-songs)))
+ (dirs '()))
+ (dolist (file files)
+ (let ((dir (file-name-directory file)))
+ (if (and dir (setq dir (directory-file-name dir))
+ (not (equal dir (car dirs))))
+ (push dir dirs))))
+ ;; Dirs might have duplicates still.
+ (setq dirs (delete-dups dirs))
+ (let ((newdirs dirs))
+ (while newdirs
+ (let ((dir (file-name-directory (pop newdirs))))
+ (when (and dir (setq dir (directory-file-name dir))
+ (not (member dir dirs)))
+ (push dir newdirs)
+ (push dir dirs)))))
+ dirs)))
+
+ ;; The UI should not provide access to such a thing anyway currently.
+ ;; But I could imagine adding in the future a browser for the "search"
+ ;; tag, which would provide things like previous searches. Not sure how
+ ;; useful that would be tho.
+ ((eq tag 'Search) (error "Not supported"))
+
+ ((null other-tag)
+ (condition-case nil
+ (mapcar 'cdr (mpc-proc-cmd-to-alist (list "list" (symbol-name tag))))
+ (mpc-proc-error
+ ;; If `tag' is not one of the expected tags, MPD burps about not
+ ;; having the relevant table.
+ ;; FIXME: check the kind of error.
+ (error "MPD does not know this tag %s" tag)
+ (mpc-assq-all tag (mpc-proc-cmd-to-alist "listallinfo")))))
+ (t
+ (condition-case nil
+ (if (member other-tag '(Search Playlist Directory))
+ (signal 'mpc-proc-error "Not implemented")
+ (mapcar 'cdr
+ (mpc-proc-cmd-to-alist
+ (list "list" (symbol-name tag)
+ (symbol-name other-tag) value))))
+ (mpc-proc-error
+ ;; DAMN!! the 3-arg form of `list' is new in 0.12 !!
+ ;; FIXME: check the kind of error.
+ (let ((other-songs (mpc-cmd-find other-tag value)))
+ (mpc-assq-all tag
+ ;; Don't use `nconc' now that mpc-cmd-find may
+ ;; return a memoized result.
+ (apply 'append other-songs))))))))
+
+(defun mpc-cmd-stop (&optional callback)
+ (mpc-proc-cmd "stop" callback))
+
+(defun mpc-cmd-clear (&optional callback)
+ (mpc-proc-cmd "clear" callback)
+ ;; (setq mpc-queue-back nil mpc-queue nil)
+ )
+
+(defun mpc-cmd-pause (&optional arg callback)
+ "Pause or resume playback of the queue of songs."
+ (lexical-let ((cb callback))
+ (mpc-proc-cmd (list "pause" arg)
+ (lambda () (mpc-status-refresh) (if cb (funcall cb))))
+ (unless callback (mpc-proc-sync))))
+
+(defun mpc-cmd-status ()
+ (mpc-proc-cmd-to-alist "status"))
+
+(defun mpc-cmd-play ()
+ (mpc-proc-cmd "play")
+ (mpc-status-refresh))
+
+(defun mpc-cmd-add (files &optional playlist)
+ "Add the songs FILES to PLAYLIST.
+If PLAYLIST is t or nil or missing, use the main playlist."
+ (mpc-proc-cmd (mpc-proc-cmd-list
+ (mapcar (lambda (file)
+ (if (stringp playlist)
+ (list "playlistadd" playlist file)
+ (list "add" file)))
+ files)))
+ (if (stringp playlist)
+ (puthash (cons 'Playlist playlist) nil mpc--find-memoize)))
+
+(defun mpc-cmd-delete (song-poss &optional playlist)
+ "Delete the songs at positions SONG-POSS from PLAYLIST.
+If PLAYLIST is t or nil or missing, use the main playlist."
+ (mpc-proc-cmd (mpc-proc-cmd-list
+ (mapcar (lambda (song-pos)
+ (if (stringp playlist)
+ (list "playlistdelete" playlist song-pos)
+ (list "delete" song-pos)))
+ ;; Sort them from last to first, so the renumbering
+ ;; caused by the earlier deletions don't affect
+ ;; later ones.
+ (sort song-poss '>))))
+ (if (stringp playlist)
+ (puthash (cons 'Playlist playlist) nil mpc--find-memoize)))
+
+
+(defun mpc-cmd-move (song-poss dest-pos &optional playlist)
+ (let ((i 0))
+ (mpc-proc-cmd
+ (mpc-proc-cmd-list
+ (mapcar (lambda (song-pos)
+ (if (>= song-pos dest-pos)
+ ;; positions past dest-pos have been
+ ;; shifted by i.
+ (setq song-pos (+ song-pos i)))
+ (prog1 (if (stringp playlist)
+ (list "playlistmove" playlist song-pos dest-pos)
+ (list "move" song-pos dest-pos))
+ (if (< song-pos dest-pos)
+ ;; This move has shifted dest-pos by 1.
+ (decf dest-pos))
+ (incf i)))
+ ;; Sort them from last to first, so the renumbering
+ ;; caused by the earlier deletions affect
+ ;; later ones a bit less.
+ (sort song-poss '>))))
+ (if (stringp playlist)
+ (puthash (cons 'Playlist playlist) nil mpc--find-memoize))))
+
+(defun mpc-cmd-update (&optional arg callback)
+ (lexical-let ((cb callback))
+ (mpc-proc-cmd (if arg (list "update" arg) "update")
+ (lambda () (mpc-status-refresh) (if cb (funcall cb))))
+ (unless callback (mpc-proc-sync))))
+
+(defun mpc-cmd-tagtypes ()
+ (mapcar 'cdr (mpc-proc-cmd-to-alist "tagtypes")))
+
+;; This was never integrated into MPD.
+;; (defun mpc-cmd-download (file)
+;; (with-current-buffer (generate-new-buffer " *mpc download*")
+;; (set-buffer-multibyte nil)
+;; (let* ((proc (mpc-proc))
+;; (stdbuf (process-buffer proc))
+;; (markpos (marker-position (process-mark proc)))
+;; (stdcoding (process-coding-system proc)))
+;; (unwind-protect
+;; (progn
+;; (set-process-buffer proc (current-buffer))
+;; (set-process-coding-system proc 'binary (cdr stdcoding))
+;; (set-marker (process-mark proc) (point))
+;; (mpc-proc-cmd (list "download" file)))
+;; (set-process-buffer proc stdbuf)
+;; (set-marker (process-mark proc) markpos stdbuf)
+;; (set-process-coding-system proc (car stdcoding) (cdr stdcoding)))
+;; ;; The command has completed, let's decode.
+;; (goto-char (point-max))
+;; (delete-char -1) ;Delete final newline.
+;; (while (re-search-backward "^>" nil t)
+;; (delete-char 1))
+;; (current-buffer))))
+
+;;; Misc ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defcustom mpc-mpd-music-directory nil
+ "Location of MPD's music directory."
+ :type '(choice (const nil) directory))
+
+(defcustom mpc-data-directory
+ (if (and (not (file-directory-p "~/.mpc"))
+ (file-directory-p "~/.emacs.d"))
+ "~/.emacs.d/mpc" "~/.mpc")
+ "Directory where MPC.el stores auxiliary data."
+ :type 'directory)
+
+(defun mpc-data-directory ()
+ (unless (file-directory-p mpc-data-directory)
+ (make-directory mpc-data-directory))
+ mpc-data-directory)
+
+(defun mpc-file-local-copy (file)
+ ;; Try to set mpc-mpd-music-directory.
+ (when (and (null mpc-mpd-music-directory)
+ (string-match "\\`localhost" mpc-host))
+ (let ((files '("~/.mpdconf" "/etc/mpd.conf"))
+ file)
+ (while (and files (not file))
+ (if (file-exists-p (car files)) (setq file (car files)))
+ (setq files (cdr files)))
+ (with-temp-buffer
+ (ignore-errors (insert-file-contents file))
+ (goto-char (point-min))
+ (if (re-search-forward "^music_directory[ ]+\"\\([^\"]+\\)\"")
+ (setq mpc-mpd-music-directory
+ (match-string 1))))))
+ ;; Use mpc-mpd-music-directory if applicable, or else try to use the
+ ;; `download' command, although it's never been accepted in `mpd' :-(
+ (if (and mpc-mpd-music-directory
+ (file-exists-p (expand-file-name file mpc-mpd-music-directory)))
+ (expand-file-name file mpc-mpd-music-directory)
+ ;; (let ((aux (expand-file-name (replace-regexp-in-string "[/]" "|" file)
+ ;; (mpc-data-directory))))
+ ;; (unless (file-exists-p aux)
+ ;; (condition-case err
+ ;; (with-local-quit
+ ;; (with-current-buffer (mpc-cmd-download file)
+ ;; (write-region (point-min) (point-max) aux)
+ ;; (kill-buffer (current-buffer))))
+ ;; (mpc-proc-error (message "Download error: %s" err) (setq aux
nil))))
+ ;; aux)
+ ))
+
+;;; Formatter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun mpc-secs-to-time (secs)
+ (if (stringp secs) (setq secs (string-to-number secs)))
+ (if (>= secs (* 60 100)) ;More than 100 minutes.
+ (format "%dh%02d" ;"%d:%02d:%02d"
+ (/ secs 3600) (% (/ secs 60) 60)) ;; (% secs 60)
+ (format "%d:%02d" (/ secs 60) (% secs 60))))
+
+(defvar mpc-tempfiles nil)
+(defconst mpc-tempfiles-reftable (make-hash-table :weakness 'key))
+
+(defun mpc-tempfiles-clean ()
+ (let ((live ()))
+ (maphash (lambda (k v) (push v live)) mpc-tempfiles-reftable)
+ (dolist (f mpc-tempfiles)
+ (unless (member f live) (ignore-errors (delete-file f))))
+ (setq mpc-tempfiles live)))
+
+(defun mpc-tempfiles-add (key file)
+ (mpc-tempfiles-clean)
+ (puthash key file mpc-tempfiles-reftable)
+ (push file mpc-tempfiles))
+
+(defun mpc-format (format-spec info &optional hscroll)
+ "Format the INFO according to FORMAT-SPEC, inserting the result at point."
+ (let* ((pos 0)
+ (start (point))
+ (col (if hscroll (- hscroll) 0))
+ (insert (lambda (str)
+ (cond
+ ((>= col 0) (insert str))
+ (t (insert (substring str (min (length str) (- col))))))))
+ (pred nil))
+ (while (string-match
"%\\(?:%\\|\\(-\\)?\\([0-9]+\\)?{\\([[:alpha:]][[:alnum:]]*\\)\\(?:-\\([^}]+\\)\\)?}\\)"
format-spec pos)
+ (let ((pre-text (substring format-spec pos (match-beginning 0))))
+ (funcall insert pre-text)
+ (setq col (+ col (string-width pre-text))))
+ (setq pos (match-end 0))
+ (if (null (match-end 3))
+ (progn
+ (funcall insert "%")
+ (setq col (+ col 1)))
+ (let* ((size (match-string 2 format-spec))
+ (tag (intern (match-string 3 format-spec)))
+ (post (match-string 4 format-spec))
+ (right-align (match-end 1))
+ (text
+ (if (eq info 'self) (symbol-name tag)
+ (case tag
+ ((Time Duration)
+ (let ((time (cdr (or (assq 'time info) (assq 'Time
info)))))
+ (setq pred (list nil)) ;Just assume it's never eq.
+ (when time
+ (mpc-secs-to-time (if (and (eq tag 'Duration)
+ (string-match ":" time))
+ (substring time (match-end 0))
+ time)))))
+ (Cover
+ (let* ((dir (file-name-directory (cdr (assq 'file info))))
+ (cover (concat dir "cover.jpg"))
+ (file (condition-case err
+ (mpc-file-local-copy cover)
+ (error (message "MPC: %s" err))))
+ image)
+ ;; (debug)
+ (push `(equal ',dir (file-name-directory (cdr (assq
'file info)))) pred)
+ (if (null file)
+ ;; Make sure we return something on which we can
+ ;; place the `mpc-pred' property, as
+ ;; a negative-cache. We could also use
+ ;; a default cover.
+ (progn (setq size nil) " ")
+ (if (null size) (setq image (create-image file))
+ (let ((tempfile (make-temp-file "mpc" nil ".jpg")))
+ (call-process "convert" nil nil nil
+ "-scale" size file tempfile)
+ (setq image (create-image tempfile))
+ (mpc-tempfiles-add image tempfile)))
+ (setq size nil)
+ (propertize dir 'display image))))
+ (t (let ((val (cdr (assq tag info))))
+ ;; For Streaming URLs, there's no other info
+ ;; than the URL in `file'. Pretend it's in `Title'.
+ (when (and (null val) (eq tag 'Title))
+ (setq val (cdr (assq 'file info))))
+ (push `(equal ',val (cdr (assq ',tag info))) pred)
+ val)))))
+ (space (when size
+ (setq size (string-to-number size))
+ (propertize " " 'display
+ (list 'space :align-to (+ col size)))))
+ (textwidth (if text (string-width text) 0))
+ (postwidth (if post (string-width post) 0)))
+ (when text
+ (let ((display
+ (if (and size
+ (> (+ postwidth textwidth) size))
+ ;; This doesn't even obey double-width chars :-(
+ (propertize
+ (if (zerop (- size postwidth 1))
+ (substring text 0 1)
+ (concat (substring text 0 (- size postwidth
textwidth 1)) "â¦"))
+ 'help-echo text)
+ text)))
+ (when (memq tag '(Artist Album Composer)) ;FIXME: wrong list.
+ (setq display
+ (propertize display
+ 'mouse-face 'highlight
+ 'follow-link t
+ 'keymap `(keymap
+ (mouse-2
+ . (lambda ()
+ (interactive)
+ (mpc-constraints-push
'noerror)
+ (mpc-constraints-restore
+ ',(list (list tag
text)))))))))
+ (funcall insert
+ (concat (when size
+ (propertize " " 'display
+ (list 'space :align-to
+ (+ col
+ (if (and size
right-align)
+ (- size postwidth
textwidth)
+ 0)))))
+ display post))))
+ (if (null size) (setq col (+ col textwidth postwidth))
+ (insert space)
+ (setq col (+ col size))))))
+ (put-text-property start (point) 'mpc-pred
+ `(lambda (info) (and ,@(nreverse pred))))))
+
+;;; The actual UI code ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar mpc-mode-map
+ (let ((map (make-keymap)))
+ (suppress-keymap map)
+ ;; (define-key map "\e" 'mpc-stop)
+ (define-key map "q" 'mpc-quit)
+ (define-key map "\r" 'mpc-select)
+ (define-key map [(shift return)] 'mpc-select-toggle)
+ (define-key map [mouse-2] 'mpc-select)
+ (define-key map [S-mouse-2] 'mpc-select-extend)
+ (define-key map [C-mouse-2] 'mpc-select-toggle)
+ (define-key map [drag-mouse-2] 'mpc-drag-n-drop)
+ ;; We use `always' because a binding to t is like a binding to nil.
+ (define-key map [follow-link] 'always)
+ ;; Doesn't work because the first click changes the buffer, so the second
+ ;; is applied elsewhere :-(
+ ;; (define-key map [(double mouse-2)] 'mpc-play-at-point)
+ (define-key map "p" 'mpc-pause)
+ map))
+
+(easy-menu-define mpc-mode-menu mpc-mode-map
+ "Menu for MPC.el."
+ '("MPC.el"
+ ["Add new browser" mpc-tagbrowser]
+ ["Update DB" mpc-update]
+ ["Quit" mpc-quit]))
+
+(defvar mpc-tool-bar-map
+ (let ((map (make-sparse-keymap)))
+ (tool-bar-local-item "mpc/prev" 'mpc-prev 'prev map
+ :enable '(not (equal (cdr (assq 'state mpc-status)) "stop")))
+ ;; FIXME: how can we bind it to the down-event?
+ (tool-bar-local-item "mpc/rewind" 'mpc-rewind 'rewind map
+ :enable '(not (equal (cdr (assq 'state mpc-status)) "stop"))
+ :button '(:toggle . (and mpc--faster-toggle-timer
+ (not mpc--faster-toggle-forward))))
+ ;; We could use a single toggle command for pause/play, with 2 different
+ ;; icons depending on whether or not it's selected, but then it'd have
+ ;; to be a toggle-button, thus displayed depressed in one of the
+ ;; two states :-(
+ (tool-bar-local-item "mpc/pause" 'mpc-pause 'pause map
+ :visible '(equal (cdr (assq 'state mpc-status)) "play")
+ :help "Pause/play")
+ (tool-bar-local-item "mpc/play" 'mpc-play 'play map
+ :visible '(not (equal (cdr (assq 'state mpc-status)) "play"))
+ :help "Play/pause")
+ ;; FIXME: how can we bind it to the down-event?
+ (tool-bar-local-item "mpc/ffwd" 'mpc-ffwd 'ffwd map
+ :enable '(not (equal (cdr (assq 'state mpc-status)) "stop"))
+ :button '(:toggle . (and mpc--faster-toggle-timer
+ mpc--faster-toggle-forward)))
+ (tool-bar-local-item "mpc/next" 'mpc-next 'next map
+ :enable '(not (equal (cdr (assq 'state mpc-status)) "stop")))
+ (tool-bar-local-item "mpc/stop" 'mpc-stop 'stop map)
+ (tool-bar-local-item "mpc/add" 'mpc-playlist-add 'add map
+ :help "Append to the playlist")
+ map))
+
+(define-derived-mode mpc-mode fundamental-mode "MPC"
+ "Major mode for the features common to all buffers of MPC."
+ (buffer-disable-undo)
+ (setq buffer-read-only t)
+ (set (make-local-variable 'tool-bar-map) mpc-tool-bar-map)
+ (set (make-local-variable 'truncate-lines) t))
+
+;;; The mpc-status-mode buffer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-derived-mode mpc-status-mode mpc-mode "MPC-Status"
+ "Major mode to display MPC status info."
+ (set (make-local-variable 'mode-line-format)
+ '("%e" mode-line-frame-identification mode-line-buffer-identification))
+ (set (make-local-variable 'window-area-factor) 3)
+ (set (make-local-variable 'header-line-format) '("MPC " mpc-volume)))
+
+(defvar mpc-status-buffer-format
+ '("%-5{Time} / %{Duration} %2{Disc--}%4{Track}" "%{Title}" "%{Album}"
"%{Artist}" "%128{Cover}"))
+
+(defun mpc-status-buffer-refresh ()
+ (let ((buf (mpc-proc-buffer (mpc-proc) 'status)))
+ (when (buffer-live-p buf)
+ (with-current-buffer buf
+ (save-excursion
+ (goto-char (point-min))
+ (when (assq 'file mpc-status)
+ (let ((inhibit-read-only t))
+ (dolist (spec mpc-status-buffer-format)
+ (let ((pred (get-text-property (point) 'mpc-pred)))
+ (if (and pred (funcall pred mpc-status))
+ (forward-line)
+ (delete-region (point) (line-beginning-position 2))
+ (ignore-errors (mpc-format spec mpc-status))
+ (insert "\n"))))
+ (unless (eobp) (delete-region (point) (point-max))))))))))
+
+(defun mpc-status-buffer-show ()
+ (interactive)
+ (let* ((buf (mpc-proc-buffer (mpc-proc) 'status))
+ (songs-buf (mpc-proc-buffer (mpc-proc) 'songs))
+ (songs-win (if songs-buf (get-buffer-window songs-buf 0))))
+ (unless (buffer-live-p buf)
+ (setq buf (get-buffer-create "*MPC-Status*"))
+ (with-current-buffer buf
+ (mpc-status-mode))
+ (mpc-proc-buffer (mpc-proc) 'status buf))
+ (if (null songs-win) (pop-to-buffer buf)
+ (let ((win (split-window songs-win 20 t)))
+ (set-window-dedicated-p songs-win nil)
+ (set-window-buffer songs-win buf)
+ (set-window-dedicated-p songs-win 'soft)))))
+
+;;; Selection management;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar mpc-separator-ol nil)
+
+(defvar mpc-select nil)
+(make-variable-buffer-local 'mpc-select)
+
+(defmacro mpc-select-save (&rest body)
+ "Execute BODY and restore the selection afterwards."
+ (declare (indent 0) (debug t))
+ `(let ((selection (mpc-select-get-selection))
+ (position (cons (buffer-substring-no-properties
+ (line-beginning-position) (line-end-position))
+ (current-column))))
+ ,@body
+ (mpc-select-restore selection)
+ (goto-char (point-min))
+ (if (re-search-forward
+ (concat "^" (regexp-quote (car position)) "$")
+ (if (overlayp mpc-separator-ol)
+ (overlay-end mpc-separator-ol))
+ t)
+ (move-to-column (cdr position)))
+ (let ((win (get-buffer-window (current-buffer) 0)))
+ (if win (set-window-point win (point))))))
+
+(defun mpc-select-get-selection ()
+ (mapcar (lambda (ol)
+ (buffer-substring-no-properties
+ (overlay-start ol) (1- (overlay-end ol))))
+ mpc-select))
+
+(defun mpc-select-restore (selection)
+ ;; Restore the selection. I.e. move the overlays back to their
+ ;; corresponding location. Actually which overlay is used for what
+ ;; doesn't matter.
+ (mapc 'delete-overlay mpc-select)
+ (setq mpc-select nil)
+ (dolist (elem selection)
+ ;; After an update, some elements may have disappeared.
+ (goto-char (point-min))
+ (when (re-search-forward
+ (concat "^" (regexp-quote elem) "$") nil t)
+ (mpc-select-make-overlay)))
+ (when mpc-tag (mpc-tagbrowser-all-select))
+ (beginning-of-line))
+
+(defun mpc-select-make-overlay ()
+ (assert (not (get-char-property (point) 'mpc-select)))
+ (let ((ol (make-overlay
+ (line-beginning-position) (line-beginning-position 2))))
+ (overlay-put ol 'mpc-select t)
+ (overlay-put ol 'face 'region)
+ (overlay-put ol 'evaporate t)
+ (push ol mpc-select)))
+
+(defun mpc-select (&optional event)
+ "Select the tag value at point."
+ (interactive (list last-nonmenu-event))
+ (mpc-event-set-point event)
+ (if (and (bolp) (eobp)) (forward-line -1))
+ (mapc 'delete-overlay mpc-select)
+ (setq mpc-select nil)
+ (if (mpc-tagbrowser-all-p)
+ nil
+ (mpc-select-make-overlay))
+ (when mpc-tag
+ (mpc-tagbrowser-all-select)
+ (mpc-selection-refresh)))
+
+(defun mpc-select-toggle (&optional event)
+ "Toggle the selection of the tag value at point."
+ (interactive (list last-nonmenu-event))
+ (mpc-event-set-point event)
+ (save-excursion
+ (cond
+ ;; The line is already selected: deselect it.
+ ((get-char-property (point) 'mpc-select)
+ (let ((ols nil))
+ (dolist (ol mpc-select)
+ (if (and (<= (overlay-start ol) (point))
+ (> (overlay-end ol) (point)))
+ (delete-overlay ol)
+ (push ol ols)))
+ (assert (= (1+ (length ols)) (length mpc-select)))
+ (setq mpc-select ols)))
+ ;; We're trying to select *ALL* additionally to others.
+ ((mpc-tagbrowser-all-p) nil)
+ ;; Select the current line.
+ (t (mpc-select-make-overlay))))
+ (when mpc-tag
+ (mpc-tagbrowser-all-select)
+ (mpc-selection-refresh)))
+
+(defun mpc-select-extend (&optional event)
+ "Extend the selection up to point."
+ (interactive (list last-nonmenu-event))
+ (mpc-event-set-point event)
+ (if (null mpc-select)
+ ;; If nothing's selected yet, fallback to selecting the elem at point.
+ (mpc-select event)
+ (save-excursion
+ (cond
+ ;; The line is already in a selected area; truncate the area.
+ ((get-char-property (point) 'mpc-select)
+ (let ((before 0)
+ (after 0)
+ (mid (line-beginning-position))
+ start end)
+ (while (and (zerop (forward-line 1))
+ (get-char-property (point) 'mpc-select))
+ (setq end (1+ (point)))
+ (incf after))
+ (goto-char mid)
+ (while (and (zerop (forward-line -1))
+ (get-char-property (point) 'mpc-select))
+ (setq start (point))
+ (incf before))
+ (if (and (= after 0) (= before 0))
+ ;; Shortening an already minimum-size region: do nothing.
+ nil
+ (if (> after before)
+ (setq end mid)
+ (setq start (1+ mid)))
+ (let ((ols '()))
+ (dolist (ol mpc-select)
+ (if (and (>= (overlay-start ol) start)
+ (< (overlay-start ol) end))
+ (delete-overlay ol)
+ (push ol ols)))
+ (setq mpc-select (nreverse ols))))))
+ ;; Extending a prior area. Look for the closest selection.
+ (t
+ (when (mpc-tagbrowser-all-p)
+ (forward-line 1))
+ (let ((before 0)
+ (count 0)
+ (dir 1)
+ (start (line-beginning-position)))
+ (while (and (zerop (forward-line 1))
+ (not (get-char-property (point) 'mpc-select)))
+ (incf count))
+ (unless (get-char-property (point) 'mpc-select)
+ (setq count nil))
+ (goto-char start)
+ (while (and (zerop (forward-line -1))
+ (not (get-char-property (point) 'mpc-select)))
+ (incf before))
+ (unless (get-char-property (point) 'mpc-select)
+ (setq before nil))
+ (when (and before (or (null count) (< before count)))
+ (setq count before)
+ (setq dir -1))
+ (goto-char start)
+ (dotimes (i (1+ (or count 0)))
+ (mpc-select-make-overlay)
+ (forward-line dir))))))
+ (when mpc-tag
+ (mpc-tagbrowser-all-select)
+ (mpc-selection-refresh))))
+
+;;; Constraint sets ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar mpc--song-search nil)
+
+(defun mpc-constraints-get-current (&optional avoid-buf)
+ "Return currently selected set of constraints.
+If AVOID-BUF is non-nil, it specifies a buffer which should be ignored
+when constructing the set of constraints."
+ (let ((constraints (if mpc--song-search `((Search ,mpc--song-search))))
+ tag select)
+ (dolist (buf (process-get (mpc-proc) 'buffers))
+ (setq buf (cdr buf))
+ (when (and (setq tag (buffer-local-value 'mpc-tag buf))
+ (not (eq buf avoid-buf))
+ (setq select
+ (with-current-buffer buf (mpc-select-get-selection))))
+ (push (cons tag select) constraints)))
+ constraints))
+
+(defun mpc-constraints-restore (constraints)
+ (let ((search (assq 'Search constraints)))
+ (setq mpc--song-search (cadr search))
+ (when search (setq constraints (delq search constraints))))
+ (dolist (buf (process-get (mpc-proc) 'buffers))
+ (setq buf (cdr buf))
+ (when (buffer-live-p buf)
+ (let* ((tag (buffer-local-value 'mpc-tag buf))
+ (constraint (assq tag constraints)))
+ (when tag
+ (with-current-buffer buf
+ (mpc-select-restore (cdr constraint)))))))
+ (mpc-selection-refresh))
+
+;; I don't get the ring.el code. I think it doesn't do what I need, but
+;; then I don't understand when what it does would be useful.
+(defun mpc-ring-make (size) (cons 0 (cons 0 (make-vector size nil))))
+(defun mpc-ring-push (ring val)
+ (aset (cddr ring) (car ring) val)
+ (setcar (cdr ring) (max (cadr ring) (1+ (car ring))))
+ (setcar ring (mod (1+ (car ring)) (length (cddr ring)))))
+(defun mpc-ring-pop (ring)
+ (setcar ring (mod (1- (car ring)) (cadr ring)))
+ (aref (cddr ring) (car ring)))
+
+(defvar mpc-constraints-ring (mpc-ring-make 10))
+
+(defun mpc-constraints-push (&optional noerror)
+ "Push the current selection on the ring for later."
+ (interactive)
+ (let ((constraints (mpc-constraints-get-current)))
+ (if (null constraints)
+ (unless noerror (error "No selection to push"))
+ (mpc-ring-push mpc-constraints-ring constraints))))
+
+(defun mpc-constraints-pop ()
+ "Recall the most recently pushed selection."
+ (interactive)
+ (let ((constraints (mpc-ring-pop mpc-constraints-ring)))
+ (if (null constraints)
+ (error "No selection to return to")
+ (mpc-constraints-restore constraints))))
+
+;;; The TagBrowser mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst mpc-tagbrowser-all-name (propertize "*ALL*" 'face 'italic))
+(defvar mpc-tagbrowser-all-ol nil)
+(make-variable-buffer-local 'mpc-tagbrowser-all-ol)
+(defvar mpc-tag-name nil) (make-variable-buffer-local 'mpc-tag-name)
+(defun mpc-tagbrowser-all-p ()
+ (and (eq (point-min) (line-beginning-position))
+ (equal mpc-tagbrowser-all-name
+ (buffer-substring (point-min) (line-end-position)))))
+
+(define-derived-mode mpc-tagbrowser-mode mpc-mode '("MPC-" mpc-tag-name)
+ (set (make-local-variable 'mode-line-process) '("" mpc-tag-name))
+ (set (make-local-variable 'mode-line-format) nil)
+ (set (make-local-variable 'header-line-format) '("" mpc-tag-name ;; "s"
+ ))
+ (set (make-local-variable 'buffer-undo-list) t)
+ )
+
+(defun mpc-tagbrowser-refresh ()
+ (mpc-select-save
+ (widen)
+ (goto-char (point-min))
+ (assert (looking-at (regexp-quote mpc-tagbrowser-all-name)))
+ (forward-line 1)
+ (let ((inhibit-read-only t))
+ (delete-region (point) (point-max))
+ (dolist (val (mpc-cmd-list mpc-tag)) (insert val "\n")))
+ (set-buffer-modified-p nil))
+ (mpc-reorder))
+
+(defun mpc-updated-db ()
+ ;; FIXME: This is not asynchronous, but is run from a process filter.
+ (unless (assq 'updating_db mpc-status)
+ (clrhash mpc--find-memoize)
+ (dolist (buf (process-get (mpc-proc) 'buffers))
+ (setq buf (cdr buf))
+ (when (buffer-local-value 'mpc-tag buf)
+ (with-current-buffer buf (with-local-quit (mpc-tagbrowser-refresh)))))
+ (with-local-quit (mpc-songs-refresh))))
+
+(defun mpc-tagbrowser-buf (tag)
+ (let ((buf (mpc-proc-buffer (mpc-proc) tag)))
+ (if (buffer-live-p buf) buf
+ (setq buf (get-buffer-create (format "*MPC %ss*" tag)))
+ (mpc-proc-buffer (mpc-proc) tag buf)
+ (with-current-buffer buf
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (if (member tag '(Directory))
+ (mpc-tagbrowser-dir-mode)
+ (mpc-tagbrowser-mode))
+ (insert mpc-tagbrowser-all-name "\n"))
+ (forward-line -1)
+ (setq mpc-tag tag)
+ (setq mpc-tag-name
+ (if (string-match "y\\'" (symbol-name tag))
+ (concat (substring (symbol-name tag) 0 -1) "ies")
+ (concat (symbol-name tag) "s")))
+ (mpc-tagbrowser-all-select)
+ (mpc-tagbrowser-refresh)
+ buf))))
+
+(defvar tag-browser-tagtypes
+ (lazy-completion-table tag-browser-tagtypes
+ (lambda ()
+ (append '("Playlist" "Directory")
+ (mpc-cmd-tagtypes)))))
+
+(defun mpc-tagbrowser (tag)
+ "Create a new browser for TAG."
+ (interactive
+ (list
+ (let ((completion-ignore-case t))
+ (intern
+ (completing-read "Tag: " tag-browser-tagtypes nil 'require-match)))))
+ (let* ((newbuf (mpc-tagbrowser-buf tag))
+ (win (get-buffer-window newbuf 0)))
+ (if win (select-window win)
+ (if (with-current-buffer (window-buffer (selected-window))
+ (derived-mode-p 'mpc-tagbrowser-mode))
+ (setq win (selected-window))
+ ;; Find a tagbrowser-mode buffer.
+ (let ((buffers (process-get (mpc-proc) 'buffers))
+ buffer)
+ (while
+ (and buffers
+ (not (and (buffer-live-p (setq buffer (cdr (pop buffers))))
+ (with-current-buffer buffer
+ (derived-mode-p 'mpc-tagbrowser-mode))
+ (setq win (get-buffer-window buffer 0))))))))
+ (if (not win)
+ (pop-to-buffer newbuf)
+ (setq win (split-window win nil 'horiz))
+ (set-window-buffer win newbuf)
+ (set-window-dedicated-p win 'soft)
+ (select-window win)
+ (balance-windows-area)))))
+
+(defun mpc-tagbrowser-all-select ()
+ "Select the special *ALL* entry if no other is selected."
+ (if mpc-select
+ (delete-overlay mpc-tagbrowser-all-ol)
+ (save-excursion
+ (goto-char (point-min))
+ (if mpc-tagbrowser-all-ol
+ (move-overlay mpc-tagbrowser-all-ol
+ (point) (line-beginning-position 2))
+ (let ((ol (make-overlay (point) (line-beginning-position 2))))
+ (overlay-put ol 'face 'region)
+ (overlay-put ol 'evaporate t)
+ (set (make-local-variable 'mpc-tagbrowser-all-ol) ol))))))
+
+;; (defvar mpc-constraints nil)
+(defun mpc-separator (active)
+ ;; Place a separator mark.
+ (unless mpc-separator-ol
+ (set (make-local-variable 'mpc-separator-ol)
+ (make-overlay (point) (point)))
+ (overlay-put mpc-separator-ol 'after-string
+ (propertize "\n"
+ 'face '(:height 0.05 :inverse-video t))))
+ (goto-char (point-min))
+ (forward-line 1)
+ (while
+ (and (member (buffer-substring-no-properties
+ (line-beginning-position) (line-end-position))
+ active)
+ (zerop (forward-line 1))))
+ (if (or (eobp) (null active))
+ (delete-overlay mpc-separator-ol)
+ (move-overlay mpc-separator-ol (1- (point)) (point))))
+
+(defun mpc-sort (active)
+ ;; Sort the active elements at the front.
+ (let ((inhibit-read-only t))
+ (goto-char (point-min))
+ (if (mpc-tagbrowser-all-p) (forward-line 1))
+ (condition-case nil
+ (sort-subr nil 'forward-line 'end-of-line
+ nil nil
+ (lambda (s1 s2)
+ (setq s1 (buffer-substring-no-properties
+ (car s1) (cdr s1)))
+ (setq s2 (buffer-substring-no-properties
+ (car s2) (cdr s2)))
+ (cond
+ ((member s1 active)
+ (if (member s2 active)
+ (let ((cmp (mpc-compare-strings s1 s2 t)))
+ (and (numberp cmp) (< cmp 0)))
+ t))
+ ((member s2 active) nil)
+ (t (let ((cmp (mpc-compare-strings s1 s2 t)))
+ (and (numberp cmp) (< cmp 0)))))))
+ ;; The comparison predicate arg is new in Emacs-22.
+ (wrong-number-of-arguments
+ (sort-subr nil 'forward-line 'end-of-line
+ (lambda ()
+ (let ((name (buffer-substring-no-properties
+ (point) (line-end-position))))
+ (cond
+ ((member name active) (concat "1" name))
+ (t (concat "2" "name"))))))))))
+
+(defvar mpc--changed-selection)
+
+(defun mpc-reorder (&optional nodeactivate)
+ "Reorder entries based on thre currently active selections.
+I.e. split the current browser buffer into a first part containing the
+entries included in the selection, then a separator, and then the entries
+not included in the selection.
+Return non-nil if a selection was deactivated."
+ (mpc-select-save
+ (let ((constraints (mpc-constraints-get-current (current-buffer)))
+ (active 'all))
+ ;; (unless (equal constraints mpc-constraints)
+ ;; (set (make-local-variable 'mpc-constraints) constraints)
+ (dolist (cst constraints)
+ (let ((vals (apply 'mpc-union
+ (mapcar (lambda (val)
+ (mpc-cmd-list mpc-tag (car cst) val))
+ (cdr cst)))))
+ (setq active
+ (if (listp active) (mpc-intersection active vals) vals))))
+
+ (when (and (listp active))
+ ;; Remove the selections if they are all in conflict with
+ ;; other constraints.
+ (let ((deactivate t))
+ (dolist (sel selection)
+ (when (member sel active) (setq deactivate nil)))
+ (when deactivate
+ ;; Variable declared/used by `mpc-select-save'.
+ (when selection
+ (setq mpc--changed-selection t))
+ (unless nodeactivate
+ (setq selection nil)
+ (mapc 'delete-overlay mpc-select)
+ (setq mpc-select nil)
+ (mpc-tagbrowser-all-select)))))
+
+ ;; FIXME: This `mpc-sort' takes a lot of time. Maybe we should
+ ;; be more clever and presume the buffer is mostly sorted already.
+ (mpc-sort (if (listp active) active))
+ (mpc-separator (if (listp active) active)))))
+
+(defun mpc-selection-refresh ()
+ (let ((mpc--changed-selection t))
+ (while mpc--changed-selection
+ (setq mpc--changed-selection nil)
+ (dolist (buf (process-get (mpc-proc) 'buffers))
+ (setq buf (cdr buf))
+ (when (and (buffer-local-value 'mpc-tag buf)
+ (not (eq buf (current-buffer))))
+ (with-current-buffer buf (mpc-reorder)))))
+ ;; FIXME: reorder the current buffer last and prevent deactivation,
+ ;; since whatever selection we made here is the most recent one
+ ;; and should hence take precedence.
+ (when mpc-tag (mpc-reorder 'nodeactivate))
+ ;; FIXME: comment?
+ (if (and mpc--song-search mpc--changed-selection)
+ (progn
+ (setq mpc--song-search nil)
+ (mpc-selection-refresh))
+ (mpc-songs-refresh))))
+
+;;; Hierarchical tagbrowser ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Todo:
+;; - Add a button on each dir to open/close it (?)
+;; - add the parent dir on the previous line, greyed-out, if it's not
+;; present (because we're in the non-selected part and the parent is
+;; in the selected part).
+
+(defvar mpc-tagbrowser-dir-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map mpc-tagbrowser-mode-map)
+ (define-key map [?\M-\C-m] 'mpc-tagbrowser-dir-toggle)
+ map))
+
+;; (defvar mpc-tagbrowser-dir-keywords
+;; '(mpc-tagbrowser-dir-hide-prefix))
+
+(define-derived-mode mpc-tagbrowser-dir-mode mpc-tagbrowser-mode '("MPC-"
mpc-tag-name)
+ ;; (set (make-local-variable 'font-lock-defaults)
+ ;; '(mpc-tagbrowser-dir-keywords t))
+ )
+
+;; (defun mpc-tagbrowser-dir-hide-prefix (limit)
+;; (while
+;; (let ((prev (buffer-substring (line-beginning-position 0)
+;; (line-end-position 0))))
+;; (
+
+(defun mpc-tagbrowser-dir-toggle (event)
+ "Open or close the element at point."
+ (interactive (list last-nonmenu-event))
+ (mpc-event-set-point event)
+ (let ((name (buffer-substring (line-beginning-position)
+ (line-end-position)))
+ (prop (intern mpc-tag)))
+ (if (not (member name (process-get (mpc-proc) prop)))
+ (process-put (mpc-proc) prop
+ (cons name (process-get (mpc-proc) prop)))
+ (let ((new (delete name (process-get (mpc-proc) prop))))
+ (setq name (concat name "/"))
+ (process-put (mpc-proc) prop
+ (delq nil
+ (mapcar (lambda (x)
+ (if (mpc-string-prefix-p name x)
+ nil x))
+ new)))))
+ (mpc-tagbrowser-refresh)))
+
+
+;;; Playlist management ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar mpc-songs-playlist nil
+ "Name of the currently selected playlist, if any.
+t means the main playlist.")
+(make-variable-buffer-local 'mpc-songs-playlist)
+
+(defun mpc-playlist-create (name)
+ "Save current playlist under name NAME."
+ (interactive "sPlaylist name: ")
+ (mpc-proc-cmd (list "save" name))
+ (let ((buf (mpc-proc-buffer (mpc-proc) 'Playlist)))
+ (when (buffer-live-p buf)
+ (with-current-buffer buf (mpc-tagbrowser-refresh)))))
+
+(defun mpc-playlist-destroy (name)
+ "Delete playlist named NAME."
+ (interactive
+ (list (completing-read "Delete playlist: " (mpc-cmd-list 'Playlist)
+ nil 'require-match)))
+ (mpc-proc-cmd (list "rm" name))
+ (let ((buf (mpc-proc-buffer (mpc-proc) 'Playlist)))
+ (when (buffer-live-p buf)
+ (with-current-buffer buf (mpc-tagbrowser-refresh)))))
+
+(defun mpc-playlist-rename (oldname newname)
+ "Rename playlist OLDNAME to NEWNAME."
+ (interactive
+ (let* ((oldname (if (and (eq mpc-tag 'Playlist) (null current-prefix-arg))
+ (buffer-substring (line-beginning-position)
+ (line-end-position))
+ (completing-read "Rename playlist: "
+ (mpc-cmd-list 'Playlist)
+ nil 'require-match)))
+ (newname (read-string (format "Rename '%s' to: " oldname))))
+ (if (zerop (length newname))
+ (error "Aborted")
+ (list oldname newname))))
+ (mpc-proc-cmd (list "rename" oldname newname))
+ (let ((buf (mpc-proc-buffer (mpc-proc) 'Playlist)))
+ (if (buffer-live-p buf)
+ (with-current-buffer buf (mpc-tagbrowser-refresh)))))
+
+(defun mpc-playlist ()
+ "Show the current playlist."
+ (interactive)
+ (mpc-constraints-push 'noerror)
+ (mpc-constraints-restore '()))
+
+(defun mpc-playlist-add ()
+ "Add the selection to the playlist."
+ (interactive)
+ (let ((songs (mapcar #'car (mpc-songs-selection))))
+ (mpc-cmd-add songs)
+ (message "Appended %d songs" (length songs))
+ ;; Return the songs added. Used in `mpc-play'.
+ songs))
+
+(defun mpc-playlist-delete ()
+ "Remove the selected songs from the playlist."
+ (interactive)
+ (unless mpc-songs-playlist
+ (error "The selected songs aren't part of a playlist."))
+ (let ((song-poss (mapcar #'cdr (mpc-songs-selection))))
+ (mpc-cmd-delete song-poss mpc-songs-playlist)
+ (mpc-songs-refresh)
+ (message "Deleted %d songs" (length song-poss))))
+
+;;; Volume management ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar mpc-volume-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [down-mouse-1] 'mpc-volume-mouse-set)
+ (define-key map [mouse-1] 'ignore)
+ (define-key map [header-line down-mouse-1] 'mpc-volume-mouse-set)
+ (define-key map [header-line mouse-1] 'ignore)
+ (define-key map [mode-line down-mouse-1] 'mpc-volume-mouse-set)
+ (define-key map [mode-line mouse-1] 'ignore)
+ map))
+
+(defvar mpc-volume nil) (put 'mpc-volume 'risky-local-variable t)
+
+(defun mpc-volume-refresh ()
+ ;; Maintain the volume.
+ (setq mpc-volume
+ (mpc-volume-widget
+ (string-to-number (cdr (assq 'volume mpc-status))))))
+
+(defvar mpc-volume-step 5)
+
+(defun mpc-volume-mouse-set (&optional event)
+ "Change volume setting."
+ (interactive (list last-nonmenu-event))
+ (let* ((posn (event-start event))
+ (diff
+ (if (memq (if (stringp (car-safe (posn-object posn)))
+ (aref (car (posn-object posn)) (cdr (posn-object
posn)))
+ (with-current-buffer (window-buffer (posn-window posn))
+ (char-after (posn-point posn))))
+ '(?â ?<))
+ (- mpc-volume-step) mpc-volume-step))
+ (newvol (+ (string-to-number (cdr (assq 'volume mpc-status))) diff)))
+ (mpc-proc-cmd (list "setvol" newvol) 'mpc-status-refresh)
+ (message "Set MPD volume to %s%%" newvol)))
+
+(defun mpc-volume-widget (vol &optional size)
+ (unless size (setq size 12.5))
+ (let ((scaledvol (* (/ vol 100.0) size)))
+ ;; (message "Volume sizes: %s - %s" (/ vol fact) (/ (- 100 vol) fact))
+ (list (propertize "<" ;; "â"
+ ;; 'face 'default
+ 'keymap mpc-volume-map
+ 'face '(:box (:line-width -2 :style pressed-button))
+ 'mouse-face '(:box (:line-width -2 :style
released-button)))
+ " "
+ (propertize "a"
+ 'display (list 'space :width scaledvol)
+ 'face '(:inverse-video t
+ :box (:line-width -2 :style released-button)))
+ (propertize "a"
+ 'display (list 'space :width (- size scaledvol))
+ 'face '(:box (:line-width -2 :style released-button)))
+ " "
+ (propertize ">" ;; "â·"
+ ;; 'face 'default
+ 'keymap mpc-volume-map
+ 'face '(:box (:line-width -2 :style pressed-button))
+ 'mouse-face '(:box (:line-width -2 :style
released-button))))))
+
+;;; MPC songs mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar mpc-current-song nil) (put 'mpc-current-song 'risky-local-variable t)
+(defvar mpc-current-updating nil) (put 'mpc-current-updating
'risky-local-variable t)
+(defvar mpc-songs-format-description nil) (put 'mpc-songs-format-description
'risky-local-variable t)
+
+(defvar mpc-previous-window-config nil)
+
+(defvar mpc-songs-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map mpc-mode-map)
+ (define-key map [remap mpc-select] 'mpc-songs-jump-to)
+ map))
+
+(defvar mpc-songpointer-set-visible nil)
+
+(defvar mpc-songs-hashcons (make-hash-table :test 'equal :weakness t)
+ "Make song file name objects unique via hash consing.
+This is used so that they can be compared with `eq', which is needed for
+`text-property-any'.")
+(defun mpc-songs-hashcons (name)
+ (or (gethash name mpc-songs-hashcons) (puthash name name
mpc-songs-hashcons)))
+(defcustom mpc-songs-format "%2{Disc--}%3{Track} %-5{Time} %25{Title}
%20{Album} %20{Artist} %10{Date}"
+ "Format used to display each song in the list of songs."
+ :type 'string)
+
+(defvar mpc-songs-totaltime)
+
+(defun mpc-songs-refresh ()
+ (let ((buf (mpc-proc-buffer (mpc-proc) 'songs)))
+ (when (buffer-live-p buf)
+ (with-current-buffer buf
+ (let ((constraints (mpc-constraints-get-current (current-buffer)))
+ (dontsort nil)
+ (inhibit-read-only t)
+ (totaltime 0)
+ (curline (cons (count-lines (point-min)
+ (line-beginning-position))
+ (buffer-substring (line-beginning-position)
+ (line-end-position))))
+ active)
+ (setq mpc-songs-playlist nil)
+ (if (null constraints)
+ ;; When there are no constraints, rather than show the list of
+ ;; all songs (which could take a while to download and
+ ;; format), we show the current playlist.
+ ;; FIXME: it would be good to be able to show the complete
+ ;; list, but that would probably require us to format it
+ ;; on-the-fly to make it bearable.
+ (setq dontsort t
+ mpc-songs-playlist t
+ active (mpc-proc-buf-to-alists
+ (mpc-proc-cmd "playlistinfo")))
+ (dolist (cst constraints)
+ (if (and (eq (car cst) 'Playlist)
+ (= 1 (length (cdr cst))))
+ (setq mpc-songs-playlist (cadr cst)))
+ ;; We don't do anything really special here for playlists,
+ ;; because it's unclear what's a correct "union" of playlists.
+ (let ((vals (apply 'mpc-union
+ (mapcar (lambda (val)
+ (mpc-cmd-find (car cst) val))
+ (cdr cst)))))
+ (setq active (if (null active)
+ (progn
+ (if (eq (car cst) 'Playlist)
+ (setq dontsort t))
+ vals)
+ (if (or dontsort
+ ;; Try to preserve ordering and
+ ;; repetitions from playlists.
+ (not (eq (car cst) 'Playlist)))
+ (mpc-intersection active vals
+ (lambda (x) (assq 'file
x)))
+ (setq dontsort t)
+ (mpc-intersection vals active
+ (lambda (x) (assq 'file
x)))))))))
+ (mpc-select-save
+ (erase-buffer)
+ ;; Sorting songs is surprisingly difficult: when comparing two
+ ;; songs with the same album name but different artist name, you
+ ;; have to know whether these are two different albums (with the
+ ;; same name) or a single album (typically a compilation).
+ ;; I punt on it and just use file-name sorting, which does the
+ ;; right thing if your library is properly arranged.
+ (dolist (song (if dontsort active
+ (sort active
+ (lambda (song1 song2)
+ (let ((cmp (mpc-compare-strings
+ (cdr (assq 'file song1))
+ (cdr (assq 'file song2)))))
+ (and (integerp cmp) (< cmp 0)))))))
+ (incf totaltime (string-to-number (or (cdr (assq 'Time song))
"0")))
+ (mpc-format mpc-songs-format song)
+ (delete-char (- (skip-chars-backward " "))) ;Remove trailing
space.
+ (insert "\n")
+ (put-text-property
+ (line-beginning-position 0) (line-beginning-position)
+ 'mpc-file (mpc-songs-hashcons (cdr (assq 'file song))))
+ (let ((pos (assq 'Pos song)))
+ (if pos
+ (put-text-property
+ (line-beginning-position 0) (line-beginning-position)
+ 'mpc-file-pos (string-to-number (cdr pos)))))
+ ))
+ (goto-char (point-min))
+ (forward-line (car curline))
+ (when (or (search-forward (cdr curline) nil t)
+ (search-backward (cdr curline) nil t))
+ (beginning-of-line))
+ (set (make-local-variable 'mpc-songs-totaltime)
+ (unless (zerop totaltime)
+ (list " " (mpc-secs-to-time totaltime))))
+ ))))
+ (let ((mpc-songpointer-set-visible t))
+ (mpc-songpointer-refresh)))
+
+(defun mpc-songs-search (string)
+ "Filter songs to those who include STRING in their metadata."
+ (interactive "sSearch for: ")
+ (setq mpc--song-search
+ (if (zerop (length string)) nil string))
+ (let ((mpc--changed-selection t))
+ (while mpc--changed-selection
+ (setq mpc--changed-selection nil)
+ (dolist (buf (process-get (mpc-proc) 'buffers))
+ (setq buf (cdr buf))
+ (when (buffer-local-value 'mpc-tag buf)
+ (with-current-buffer buf (mpc-reorder))))
+ (mpc-songs-refresh))))
+
+(defun mpc-songs-kill-search ()
+ "Turn off the current search restriction."
+ (interactive)
+ (mpc-songs-search nil))
+
+(defun mpc-songs-selection ()
+ "Return the list of songs currently selected."
+ (let ((buf (mpc-proc-buffer (mpc-proc) 'songs)))
+ (when (buffer-live-p buf)
+ (with-current-buffer buf
+ (save-excursion
+ (let ((files ()))
+ (if mpc-select
+ (dolist (ol mpc-select)
+ (push (cons
+ (get-text-property (overlay-start ol) 'mpc-file)
+ (get-text-property (overlay-start ol) 'mpc-file-pos))
+ files))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (push (cons
+ (get-text-property (point) 'mpc-file)
+ (get-text-property (point) 'mpc-file-pos))
+ files)
+ (forward-line 1)))
+ (nreverse files)))))))
+
+(defun mpc-songs-jump-to (song-file &optional posn)
+ "Jump to song SONG-FILE, interactively, this is the song at point."
+ (interactive
+ (let* ((event last-nonmenu-event)
+ (posn (event-end event)))
+ (with-selected-window (posn-window posn)
+ (goto-char (posn-point posn))
+ (list (get-text-property (point) 'mpc-file)
+ posn))))
+ (let* ((plbuf (mpc-proc-cmd "playlist"))
+ (re (concat "^\\([0-9]+\\):" (regexp-quote song-file) "$"))
+ (sn (with-current-buffer plbuf
+ (goto-char (point-min))
+ (when (re-search-forward re nil t)
+ (match-string 1)))))
+ (cond
+ ((null sn) (error "This song is not in the playlist"))
+ ((null (with-current-buffer plbuf (re-search-forward re nil t)))
+ ;; song-file only appears once in the playlist: no ambiguity,
+ ;; we're good to go!
+ (mpc-proc-cmd (list "play" sn)))
+ (t
+ ;; The song appears multiple times in the playlist. If the current
+ ;; buffer holds not only the destination song but also the current
+ ;; song, then we will move in the playlist to the same relative
+ ;; position as in the buffer. Otherwise, we will simply choose the
+ ;; song occurrence closest to the current song.
+ (with-selected-window (posn-window posn)
+ (let* ((cur (and (markerp overlay-arrow-position)
+ (marker-position overlay-arrow-position)))
+ (dest (save-excursion
+ (goto-char (posn-point posn))
+ (line-beginning-position)))
+ (lines (when cur (* (if (< cur dest) 1 -1)
+ (count-lines cur dest)))))
+ (with-current-buffer plbuf
+ (goto-char (point-min))
+ ;; Start the search from the current song.
+ (forward-line (string-to-number
+ (or (cdr (assq 'song mpc-status)) "0")))
+ ;; If the current song is also displayed in the buffer,
+ ;; then try to move to the same relative position.
+ (if lines (forward-line lines))
+ ;; Now search the closest occurrence.
+ (let* ((next (save-excursion
+ (when (re-search-forward re nil t)
+ (cons (point) (match-string 1)))))
+ (prev (save-excursion
+ (when (re-search-backward re nil t)
+ (cons (point) (match-string 1)))))
+ (sn (cdr (if (and next prev)
+ (if (< (- (car next) (point))
+ (- (point) (car prev)))
+ next prev)
+ (or next prev)))))
+ (assert sn)
+ (mpc-proc-cmd (concat "play " sn))))))))))
+
+(define-derived-mode mpc-songs-mode mpc-mode "MPC-song"
+ (setq mpc-songs-format-description
+ (with-temp-buffer (mpc-format mpc-songs-format 'self) (buffer-string)))
+ (set (make-local-variable 'header-line-format)
+ ;; '("MPC " mpc-volume " " mpc-current-song)
+ (list (propertize " " 'display '(space :align-to 0))
+ ;; 'mpc-songs-format-description
+ '(:eval
+ (let ((hscroll (window-hscroll)))
+ (with-temp-buffer
+ (mpc-format mpc-songs-format 'self hscroll)
+ ;; That would be simpler than the hscroll handling in
+ ;; mpc-format, but currently move-to-column does not
+ ;; recognize :space display properties.
+ ;; (move-to-column hscroll)
+ ;; (delete-region (point-min) (point))
+ (buffer-string))))))
+ (set (make-local-variable 'mode-line-format)
+ '("%e" mode-line-frame-identification mode-line-buffer-identification
+ #(" " 0 3
+ (help-echo "mouse-1: Select (drag to resize)\nmouse-2: Make current
window occupy the whole frame\nmouse-3: Remove current window from display"))
+ mode-line-position
+ #(" " 0 2
+ (help-echo "mouse-1: Select (drag to resize)\nmouse-2: Make current
window occupy the whole frame\nmouse-3: Remove current window from display"))
+ mpc-songs-totaltime
+ mpc-current-updating
+ #(" " 0 2
+ (help-echo "mouse-1: Select (drag to resize)\nmouse-2: Make current
window occupy the whole frame\nmouse-3: Remove current window from display"))
+ (mpc--song-search
+ (:propertize
+ ("Search=\"" mpc--song-search "\"")
+ help-echo "mouse-2: kill this search"
+ follow-link t
+ mouse-face mode-line-highlight
+ keymap (keymap (mode-line keymap
+ (mouse-2 . mpc-songs-kill-search))))
+ (:propertize "NoSearch"
+ help-echo "mouse-2: set a search restriction"
+ follow-link t
+ mouse-face mode-line-highlight
+ keymap (keymap (mode-line keymap (mouse-2 . mpc-songs-search)))))))
+
+ ;; (set (make-local-variable 'mode-line-process)
+ ;; '("" ;; mpc-volume " "
+ ;; mpc-songs-totaltime
+ ;; mpc-current-updating))
+ )
+
+(defun mpc-songpointer-set (pos)
+ (let* ((win (get-buffer-window (current-buffer) t))
+ (visible (when win
+ (or mpc-songpointer-set-visible
+ (and (markerp overlay-arrow-position)
+ (eq (marker-buffer overlay-arrow-position)
+ (current-buffer))
+ (<= (window-start win) overlay-arrow-position)
+ (< overlay-arrow-position (window-end win)))))))
+ (unless (local-variable-p 'overlay-arrow-position)
+ (set (make-local-variable 'overlay-arrow-position) (make-marker)))
+ (move-marker overlay-arrow-position pos)
+ ;; If the arrow was visible, try to keep it that way.
+ (if (and visible pos
+ (or (> (window-start win) pos) (>= pos (window-end win t))))
+ (set-window-point win pos))))
+
+(defun mpc-songpointer-refresh ()
+ (let ((buf (mpc-proc-buffer (mpc-proc) 'songs)))
+ (when (buffer-live-p buf)
+ (with-current-buffer buf
+ (let* ((pos (text-property-any
+ (point-min) (point-max)
+ 'mpc-file (mpc-songs-hashcons
+ (cdr (assq 'file mpc-status)))))
+ (other (when pos
+ (save-excursion
+ (goto-char pos)
+ (text-property-any
+ (line-beginning-position 2) (point-max)
+ 'mpc-file (mpc-songs-hashcons
+ (cdr (assq 'file mpc-status))))))))
+ (if other
+ ;; The song appears multiple times in the buffer.
+ ;; We need to be careful to choose the right occurrence.
+ (mpc-proc-cmd "playlist" 'mpc-songpointer-refresh-hairy)
+ (mpc-songpointer-set pos)))))))
+
+(defun mpc-songpointer-context (size plbuf)
+ (with-current-buffer plbuf
+ (goto-char (point-min))
+ (forward-line (string-to-number (or (cdr (assq 'song mpc-status)) "0")))
+ (let ((context-before '())
+ (context-after '()))
+ (save-excursion
+ (dotimes (i size)
+ (when (re-search-backward "^[0-9]+:\\(.*\\)" nil t)
+ (push (mpc-songs-hashcons (match-string 1)) context-before))))
+ ;; Skip the actual current song.
+ (forward-line 1)
+ (dotimes (i size)
+ (when (re-search-forward "^[0-9]+:\\(.*\\)" nil t)
+ (push (mpc-songs-hashcons (match-string 1)) context-after)))
+ ;; If there isn't `size' context, then return nil.
+ (unless (and (< (length context-before) size)
+ (< (length context-after) size))
+ (cons (nreverse context-before) (nreverse context-after))))))
+
+(defun mpc-songpointer-score (context pos)
+ (let ((count 0))
+ (goto-char pos)
+ (dolist (song (car context))
+ (and (zerop (forward-line -1))
+ (eq (get-text-property (point) 'mpc-file) song)
+ (incf count)))
+ (goto-char pos)
+ (dolist (song (cdr context))
+ (and (zerop (forward-line 1))
+ (eq (get-text-property (point) 'mpc-file) song)
+ (incf count)))
+ count))
+
+(defun mpc-songpointer-refresh-hairy ()
+ ;; Based on the complete playlist, we should figure out where in the
+ ;; song buffer is the currently playing song.
+ (let ((plbuf (current-buffer))
+ (buf (mpc-proc-buffer (mpc-proc) 'songs)))
+ (when (buffer-live-p buf)
+ (with-current-buffer buf
+ (let* ((context-size 0)
+ (context '(() . ()))
+ (pos (text-property-any
+ (point-min) (point-max)
+ 'mpc-file (mpc-songs-hashcons
+ (cdr (assq 'file mpc-status)))))
+ (score 0)
+ (other pos))
+ (while
+ (setq other
+ (save-excursion
+ (goto-char other)
+ (text-property-any
+ (line-beginning-position 2) (point-max)
+ 'mpc-file (mpc-songs-hashcons
+ (cdr (assq 'file mpc-status))))))
+ ;; There is an `other' contestant.
+ (let ((other-score (mpc-songpointer-score context other)))
+ (cond
+ ;; `other' is worse: try the next one.
+ ((< other-score score) nil)
+ ;; `other' is better: remember it and then search further.
+ ((> other-score score)
+ (setq pos other)
+ (setq score other-score))
+ ;; Both are equal and increasing the context size won't help.
+ ;; Arbitrarily choose one of the two and keep looking
+ ;; for a better match.
+ ((< score context-size) nil)
+ (t
+ ;; Score is equal and increasing context might help: try it.
+ (incf context-size)
+ (let ((new-context
+ (mpc-songpointer-context context-size plbuf)))
+ (if (null new-context)
+ ;; There isn't more context: choose one arbitrarily
+ ;; and keep looking for a better match elsewhere.
+ (decf context-size)
+ (setq context new-context)
+ (setq score (mpc-songpointer-score context pos))
+ (save-excursion
+ (goto-char other)
+ ;; Go back one line so we find `other' again.
+ (setq other (line-beginning-position 0)))))))))
+ (mpc-songpointer-set pos))))))
+
+(defun mpc-current-refresh ()
+ ;; Maintain the current data.
+ (mpc-status-buffer-refresh)
+ (setq mpc-current-updating
+ (if (assq 'updating_db mpc-status) " Updating-DB"))
+ (ignore-errors
+ (setq mpc-current-song
+ (when (assq 'file mpc-status)
+ (concat " "
+ (mpc-secs-to-time (cdr (assq 'time mpc-status)))
+ " "
+ (cdr (assq 'Title mpc-status))
+ " ("
+ (cdr (assq 'Artist mpc-status))
+ " / "
+ (cdr (assq 'Album mpc-status))
+ ")"))))
+ (force-mode-line-update t))
+
+(defun mpc-songs-buf ()
+ (let ((buf (mpc-proc-buffer (mpc-proc) 'songs)))
+ (if (buffer-live-p buf) buf
+ (with-current-buffer (setq buf (get-buffer-create "*MPC-Songs*"))
+ (mpc-proc-buffer (mpc-proc) 'songs buf)
+ (mpc-songs-mode)
+ buf))))
+
+(defun mpc-update ()
+ "Tell MPD to refresh its database."
+ (interactive)
+ (mpc-cmd-update))
+
+(defun mpc-quit ()
+ "Quit Music Player Daemon."
+ (interactive)
+ (let* ((proc mpc-proc)
+ (bufs (mapcar 'cdr (if proc (process-get proc 'buffers))))
+ (wins (mapcar (lambda (buf) (get-buffer-window buf 0)) bufs))
+ (song-buf (mpc-songs-buf))
+ frames)
+ ;; Collect all the frames where MPC buffers appear.
+ (dolist (win wins)
+ (when (and win (not (memq (window-frame win) frames)))
+ (push (window-frame win) frames)))
+ (if (and frames song-buf
+ (with-current-buffer song-buf mpc-previous-window-config))
+ (progn
+ (select-frame (car frames))
+ (set-window-configuration
+ (with-current-buffer song-buf mpc-previous-window-config)))
+ ;; Now delete the ones that show nothing else than MPC buffers.
+ (dolist (frame frames)
+ (let ((delete t))
+ (dolist (win (window-list frame))
+ (unless (memq (window-buffer win) bufs) (setq delete nil)))
+ (if delete (ignore-errors (delete-frame frame))))))
+ ;; Then kill the buffers.
+ (mapc 'kill-buffer bufs)
+ (mpc-status-stop)
+ (if proc (delete-process proc))))
+
+(defun mpc-stop ()
+ "Stop playing the current queue of songs."
+ (interactive)
+ (mpc-cmd-stop)
+ (mpc-cmd-clear)
+ (mpc-status-refresh))
+
+(defun mpc-pause ()
+ "Pause playing."
+ (interactive)
+ (mpc-cmd-pause "1"))
+
+(defun mpc-resume ()
+ "Pause playing."
+ (interactive)
+ (mpc-cmd-pause "0"))
+
+(defun mpc-play ()
+ "Start playing whatever is selected."
+ (interactive)
+ (if (member (cdr (assq 'state (mpc-cmd-status))) '("pause"))
+ (mpc-resume)
+ ;; When playing the playlist ends, the playlist isn't cleared, but the
+ ;; user probably doesn't want to re-listen to it before getting to
+ ;; listen to what he just selected.
+ ;; (if (member (cdr (assq 'state (mpc-cmd-status))) '("stop"))
+ ;; (mpc-cmd-clear))
+ ;; Actually, we don't use mpc-play to append to the playlist any more,
+ ;; so we can just always empty the playlist.
+ (mpc-cmd-clear)
+ (if (mpc-playlist-add)
+ (if (member (cdr (assq 'state (mpc-cmd-status))) '("stop"))
+ (mpc-cmd-play))
+ (error "Don't know what to play"))))
+
+(defun mpc-next ()
+ "Jump to the next song in the queue."
+ (interactive)
+ (mpc-proc-cmd "next")
+ (mpc-status-refresh))
+
+(defun mpc-prev ()
+ "Jump to the beginning of the current song, or to the previous song."
+ (interactive)
+ (let ((time (cdr (assq 'time mpc-status))))
+ ;; Here we rely on the fact that string-to-number silently ignores
+ ;; everything after a non-digit char.
+ (cond
+ ;; Go back to the beginning of current song.
+ ((and time (> (string-to-number time) 0))
+ (mpc-proc-cmd (list "seekid" (cdr (assq 'songid mpc-status)) 0)))
+ ;; We're at the beginning of the first song of the playlist.
+ ;; Fetch the previous one from `mpc-queue-back'.
+ ;; ((and (zerop (string-to-number (cdr (assq 'song mpc-status))))
+ ;; mpc-queue-back)
+ ;; ;; Because we use cmd-list rather than cmd-play, the queue is not
+ ;; ;; automatically updated.
+ ;; (let ((prev (pop mpc-queue-back)))
+ ;; (push prev mpc-queue)
+ ;; (mpc-proc-cmd
+ ;; (mpc-proc-cmd-list
+ ;; (list (list "add" prev)
+ ;; (list "move" (cdr (assq 'playlistlength mpc-status)) "0")
+ ;; "previous")))))
+ ;; We're at the beginning of a song, but not the first one.
+ (t (mpc-proc-cmd "previous")))
+ (mpc-status-refresh)))
+
+(defvar mpc-last-seek-time '(0 . 0))
+
+(defun mpc--faster (event speedup step)
+ "Fast forward."
+ (interactive (list last-nonmenu-event))
+ (let ((repeat-delay (/ (abs (float step)) speedup)))
+ (if (not (memq 'down (event-modifiers event)))
+ (let* ((currenttime (float-time))
+ (last-time (- currenttime (car mpc-last-seek-time))))
+ (if (< last-time (* 0.9 repeat-delay))
+ nil ;; Trottle
+ (let* ((status (if (< last-time 1.0)
+ mpc-status (mpc-cmd-status)))
+ (songid (cdr (assq 'songid status)))
+ (time (if songid
+ (if (< last-time 1.0)
+ (cdr mpc-last-seek-time)
+ (string-to-number
+ (cdr (assq 'time status)))))))
+ (setq mpc-last-seek-time
+ (cons currenttime (setq time (+ time step))))
+ (mpc-proc-cmd (list "seekid" songid time)
+ 'mpc-status-refresh))))
+ (let ((status (mpc-cmd-status)))
+ (lexical-let* ((songid (cdr (assq 'songid status)))
+ (step step)
+ (time (if songid (string-to-number
+ (cdr (assq 'time status))))))
+ (let ((timer (run-with-timer
+ t repeat-delay
+ (lambda ()
+ (mpc-proc-cmd (list "seekid" songid
+ (setq time (+ time step)))
+ 'mpc-status-refresh)))))
+ (while (mouse-movement-p
+ (event-basic-type (setq event (read-event)))))
+ (cancel-timer timer)))))))
+
+(defvar mpc--faster-toggle-timer nil)
+(defun mpc--faster-stop ()
+ (when mpc--faster-toggle-timer
+ (cancel-timer mpc--faster-toggle-timer)
+ (setq mpc--faster-toggle-timer nil)))
+
+(defun mpc--faster-toggle-refresh ()
+ (if (equal (cdr (assq 'state mpc-status)) "stop")
+ (mpc--faster-stop)))
+
+(defun mpc--songduration ()
+ (string-to-number
+ (let ((s (cdr (assq 'time mpc-status))))
+ (if (not (string-match ":" s))
+ (error "Unexpected time format %S" s)
+ (substring s (match-end 0))))))
+
+(defvar mpc--faster-toggle-forward nil)
+(defvar mpc--faster-acceleration 0.5)
+(defun mpc--faster-toggle (speedup step)
+ (setq speedup (float speedup))
+ (if mpc--faster-toggle-timer
+ (mpc--faster-stop)
+ (mpc-status-refresh) (mpc-proc-sync)
+ (lexical-let* ((speedup speedup)
+ songid ;The ID of the currently ffwd/rewinding song.
+ songnb ;The position of that song in the playlist.
+ songduration ;The duration of that song.
+ songtime ;The time of the song last time we ran.
+ oldtime ;The timeoftheday last time we ran.
+ prevsongid) ;The song we're in the process leaving.
+ (let ((fun
+ (lambda ()
+ (let ((newsongid (cdr (assq 'songid mpc-status)))
+ (newsongnb (cdr (assq 'song mpc-status))))
+
+ (if (and (equal prevsongid newsongid)
+ (not (equal prevsongid songid)))
+ ;; We left prevsongid and came back to it. Pretend it
+ ;; didn't happen.
+ (setq newsongid songid))
+
+ (cond
+ ((null newsongid) (mpc--faster-stop))
+ ((not (equal songid newsongid))
+ ;; We jumped to another song: reset.
+ (setq songid newsongid)
+ (setq songtime (string-to-number
+ (cdr (assq 'time mpc-status))))
+ (setq songduration (mpc--songduration))
+ (setq oldtime (float-time)))
+ ((and (>= songtime songduration) mpc--faster-toggle-forward)
+ ;; Skip to the beginning of the next song.
+ (if (not (equal (cdr (assq 'state mpc-status)) "play"))
+ (mpc-proc-cmd "next" 'mpc-status-refresh)
+ ;; If we're playing, this is done automatically, so we
+ ;; don't need to do anything, or rather we *shouldn't*
+ ;; do anything otherwise there's a race condition where
+ ;; we could skip straight to the next next song.
+ nil))
+ ((and (<= songtime 0) (not mpc--faster-toggle-forward))
+ ;; Skip to the end of the previous song.
+ (setq prevsongid songid)
+ (mpc-proc-cmd "previous"
+ (lambda ()
+ (mpc-status-refresh
+ (lambda ()
+ (setq songid (cdr (assq 'songid mpc-status)))
+ (setq songtime (setq songduration
(mpc--songduration)))
+ (setq oldtime (float-time))
+ (mpc-proc-cmd (list "seekid" songid songtime)))))))
+ (t
+ (setq speedup (+ speedup mpc--faster-acceleration))
+ (let ((newstep
+ (truncate (* speedup (- (float-time) oldtime)))))
+ (if (<= newstep 1) (setq newstep 1))
+ (setq oldtime (+ oldtime (/ newstep speedup)))
+ (if (not mpc--faster-toggle-forward)
+ (setq newstep (- newstep)))
+ (setq songtime (min songduration (+ songtime newstep)))
+ (unless (>= songtime songduration)
+ (condition-case nil
+ (mpc-proc-cmd
+ (list "seekid" songid songtime)
+ 'mpc-status-refresh)
+ (mpc-proc-error (mpc-status-refresh)))))))
+ (setq songnb newsongnb)))))
+ (setq mpc--faster-toggle-forward (> step 0))
+ (funcall fun) ;Initialize values.
+ (setq mpc--faster-toggle-timer
+ (run-with-timer t 0.3 fun))))))
+
+
+
+(defvar mpc-faster-speedup 8)
+
+(defun mpc-ffwd (event)
+ "Fast forward."
+ (interactive (list last-nonmenu-event))
+ ;; (mpc--faster event 4.0 1)
+ (mpc--faster-toggle mpc-faster-speedup 1))
+
+(defun mpc-rewind (event)
+ "Fast rewind."
+ (interactive (list last-nonmenu-event))
+ ;; (mpc--faster event 4.0 -1)
+ (mpc--faster-toggle mpc-faster-speedup -1))
+
+
+(defun mpc-play-at-point (&optional event)
+ (interactive (list last-nonmenu-event))
+ (mpc-select event)
+ (mpc-play))
+
+;; (defun mpc-play-tagval ()
+;; "Play all the songs of the tag at point."
+;; (interactive)
+;; (let* ((val (buffer-substring (line-beginning-position)
(line-end-position)))
+;; (songs (mapcar 'cdar
+;; (mpc-proc-buf-to-alists
+;; (mpc-proc-cmd (list "find" mpc-tag val))))))
+;; (mpc-cmd-add songs)
+;; (if (member (cdr (assq 'state (mpc-cmd-status))) '("stop"))
+;; (mpc-cmd-play))))
+
+;;; Drag'n'drop support ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Todo:
+;; the main thing to do here, is to provide visual feedback during the drag:
+;; - change the mouse-cursor.
+;; - highlight/select the source and the current destination.
+
+(defun mpc-drag-n-drop (event)
+ "DWIM for a drag EVENT."
+ (interactive "e")
+ (let* ((start (event-start event))
+ (end (event-end event))
+ (start-buf (window-buffer (posn-window start)))
+ (end-buf (window-buffer (posn-window end)))
+ (songs
+ (with-current-buffer start-buf
+ (goto-char (posn-point start))
+ (if (get-text-property (point) 'mpc-select)
+ ;; FIXME: actually we should only consider the constraints
+ ;; corresponding to the selection in this particular buffer.
+ (mpc-songs-selection)
+ (cond
+ ((and (derived-mode-p 'mpc-songs-mode)
+ (get-text-property (point) 'mpc-file))
+ (list (cons (get-text-property (point) 'mpc-file)
+ (get-text-property (point) 'mpc-file-pos))))
+ ((and mpc-tag (not (mpc-tagbrowser-all-p)))
+ (mapcar (lambda (song)
+ (list (cdr (assq 'file song))))
+ (mpc-cmd-find
+ mpc-tag
+ (buffer-substring (line-beginning-position)
+ (line-end-position)))))
+ (t
+ (error "Unsupported starting position for drag'n'drop
gesture")))))))
+ (with-current-buffer end-buf
+ (goto-char (posn-point end))
+ (cond
+ ((eq mpc-tag 'Playlist)
+ ;; Adding elements to a named playlist.
+ (let ((playlist (if (or (mpc-tagbrowser-all-p)
+ (and (bolp) (eolp)))
+ (error "Not a playlist")
+ (buffer-substring (line-beginning-position)
+ (line-end-position)))))
+ (mpc-cmd-add (mapcar 'car songs) playlist)
+ (message "Added %d songs to %s" (length songs) playlist)
+ (if (member playlist
+ (cdr (assq 'Playlist (mpc-constraints-get-current))))
+ (mpc-songs-refresh))))
+ ((derived-mode-p 'mpc-songs-mode)
+ (cond
+ ((null mpc-songs-playlist)
+ (error "The songs shown do not belong to a playlist"))
+ ((eq start-buf end-buf)
+ ;; Moving songs within the shown playlist.
+ (let ((dest-pos (get-text-property (point) 'mpc-file-pos)))
+ (mpc-cmd-move (mapcar 'cdr songs) dest-pos mpc-songs-playlist)
+ (message "Moved %d songs" (length songs))))
+ (t
+ ;; Adding songs to the shown playlist.
+ (let ((dest-pos (get-text-property (point) 'mpc-file-pos))
+ (pl (if (stringp mpc-songs-playlist)
+ (mpc-cmd-find 'Playlist mpc-songs-playlist)
+ (mpc-proc-cmd-to-alist "playlist"))))
+ ;; MPD's protocol does not let us add songs at a particular
+ ;; position in a playlist, so we first have to add them to the
+ ;; end, and then move them to their final destination.
+ (mpc-cmd-add (mapcar 'car songs) mpc-songs-playlist)
+ (mpc-cmd-move (let ((poss '()))
+ (dotimes (i (length songs))
+ (push (+ i (length pl)) poss))
+ (nreverse poss)) dest-pos mpc-songs-playlist)
+ (message "Added %d songs" (length songs)))))
+ (mpc-songs-refresh))
+ (t
+ (error "Unsupported drag'n'drop gesture"))))))
+
+;;; Toplevel ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defcustom mpc-frame-alist '((name . "MPC") (tool-bar-lines . 1)
+ (font . "Sans"))
+ "Alist of frame parameters for the MPC frame."
+ :type 'alist)
+
+;;;###autoload
+(defun mpc ()
+ "Main entry point for MPC."
+ (interactive
+ (progn
+ (if current-prefix-arg
+ (setq mpc-host (read-string "MPD host and port: " nil nil mpc-host)))
+ nil))
+ (let* ((song-buf (mpc-songs-buf))
+ (song-win (get-buffer-window song-buf 0)))
+ (if song-win
+ (select-window song-win)
+ (if (or (window-dedicated-p (selected-window))
+ (window-minibuffer-p))
+ (ignore-errors (select-frame (make-frame mpc-frame-alist)))
+ (with-current-buffer song-buf
+ (set (make-local-variable 'mpc-previous-window-config)
+ (current-window-configuration))))
+ (let* ((win1 (selected-window))
+ (win2 (split-window))
+ (tags mpc-browser-tags))
+ (unless tags (error "Need at least one entry in `mpc-browser-tags'"))
+ (set-window-buffer win2 song-buf)
+ (set-window-dedicated-p win2 'soft)
+ (mpc-status-buffer-show)
+ (while
+ (progn
+ (set-window-buffer win1 (mpc-tagbrowser-buf (pop tags)))
+ (set-window-dedicated-p win1 'soft)
+ tags)
+ (setq win1 (split-window win1 nil 'horiz)))))
+ (balance-windows-area))
+ (mpc-songs-refresh)
+ (mpc-status-refresh))
+
+(provide 'mpc)
+
+;; arch-tag: 4794b2f5-59e6-4f26-b695-650b3e002f37
+;;; mpc.el ends here
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] emacs etc/NEWS lisp/ChangeLog etc/images/mpc/ad...,
Stefan Monnier <=