--- /dev/null
+#-sbcl (error "No known socket interface for ~a" (lisp-implementation-type))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require 'sb-bsd-sockets))
+(defpackage :lirc (:use :cl :sb-bsd-sockets))
+(in-package :lirc)
+
+(defvar *socket* nil)
+(defvar *translations* (make-hash-table :test 'equal))
+(defvar *bindings* '())
+(defvar *button* nil)
+(defvar *button-repeat* 0)
+(defvar *button-name* "")
+(defvar *button-remote* "")
+
+(defun disconnect ()
+ (if *socket*
+ (close (prog1 *socket*
+ (setf *socket* nil)))))
+
+(defun connect (&key (socket "/dev/lircd"))
+ (disconnect)
+ (setf *socket* (let ((sk (make-instance 'local-socket :type :stream)))
+ (socket-connect sk socket)
+ (socket-make-stream sk :input t :output t)))
+ (values))
+
+(defun read-delim (in delim)
+ (let ((buf (make-array '(16) :element-type 'character :adjustable t :fill-pointer 0)))
+ (loop (let ((b (read-char in nil delim)))
+ (if (eq b delim)
+ (return (subseq buf 0 (fill-pointer buf)))
+ (vector-push-extend b buf))))))
+
+;(defun bytevec->string (vec)
+; (map 'string #'code-char vec))
+
+(defun get-keypress-raw ()
+ (if (null *socket*)
+ (error "Not connected to lircd"))
+ (with-input-from-string (lin (read-delim *socket* #\newline))
+ (let* ((code (read-delim lin #\space))
+ (repeat (read-delim lin #\space))
+ (name (read-delim lin #\space))
+ (remote (read-delim lin #\space)))
+ (declare (type string code repeat name remote))
+ (values name remote (parse-integer repeat :radix 16) (parse-integer code :radix 16)))))
+
+(defun def-translation (symbol key &optional remote)
+ (setf (gethash (if remote
+ (list (string-upcase remote)
+ (string-upcase key))
+ (string-upcase key))
+ *translations*) symbol))
+
+(defun translate (remote key)
+ (setf remote (string-upcase remote)
+ key (string-upcase key))
+ (cond ((gethash (list remote key) *translations*))
+ ((gethash key *translations*))
+ ((intern key (find-package 'keyword)))))
+
+(defun get-keypress ()
+ (multiple-value-bind (key remote repeat)
+ (get-keypress-raw)
+ (values (translate remote key) repeat)))
+
+(defun get-bindings (key)
+ (mapcar #'first
+ (stable-sort (let ((ret '()))
+ (dolist (binding *bindings* ret)
+ (multiple-value-bind (sel when prio fun)
+ (values-list binding)
+ (if (and (ecase when
+ ((:first) (eq ret '()))
+ ((:always) t))
+ (etypecase sel
+ (symbol (or (eq sel t)
+ (eq sel key)))
+ (function (funcall sel key))))
+ (setf ret (append ret `((,fun ,prio))))))))
+ #'> :key #'second)))
+
+(defmacro defkey (key &body body)
+ `(push (list ,key :first 0 #'(lambda () ,@body))
+ *bindings*))
+
+(defmacro with-bound-keys* (bindings defwhen defprio &body body)
+ (let ((blist (mapcar #'(lambda (binding)
+ (destructuring-bind ((key &key (prio defprio) (when defwhen)) &body body)
+ binding
+ `(list ,key ,when ,prio #'(lambda () ,@body))))
+ bindings)))
+ `(let ((*bindings* (list* ,@blist *bindings*)))
+ ,@body)))
+
+(defmacro with-bound-keys (bindings &body body)
+ `(with-bound-keys* ,bindings :always 0 ,@body))
+
+(defmacro keycase (&rest bindings)
+ `(multiple-value-bind (name remote repeat)
+ (get-keypress-raw)
+ (let* ((*button* (translate remote name))
+ (*button-name* name)
+ (*button-remote* remote)
+ (*button-repeat* repeat)
+ (handlers (with-bound-keys* ,bindings :first 0
+ (get-bindings *button*))))
+ (restart-case
+ (let ((first t)
+ (ret '()))
+ (dolist (handler handlers (values-list ret))
+ (restart-case
+ (let ((ret2 (multiple-value-list (funcall handler))))
+ (if first
+ (setf first nil
+ ret ret2)))
+ (ignore-handler ()
+ :report "Ignore this key handler"
+ nil))))
+ (ignore-key ()
+ :report "Ignore this key press and return NIL from KEYCASE"
+ nil)))))
+
+(defmacro keyloop (&rest bindings)
+ (let ((start (gensym "START")))
+ `(block nil
+ (tagbody
+ ,start
+ (keycase ,@bindings)
+ (go ,start)))))
+
+(export '(connect disconnect
+ def-translation get-keypress
+ *button* *button-repeat* *button-name* *button-remote*
+ defkey with-bound-keys keycase keyloop ignore-key ignore-handler))
+(provide :lirc)
--- /dev/null
+;;;; MPCL -- Common Lisp MPD Client library
+
+#-sbcl (error "No known socket interface for ~a" (lisp-implementation-type))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require 'sb-bsd-sockets)
+ (require 'cl-ppcre))
+(defpackage :mpcl (:use :cl :sb-bsd-sockets))
+(in-package :mpcl)
+
+;;; Global variables
+(defvar *socket* nil)
+(defvar *last-command* 0)
+(defvar *last-server* nil)
+(defvar *retries* 0)
+#+sbcl (defvar *conn-lock* (sb-thread:make-mutex))
+
+;;; Utility functions
+(defmacro concat (&rest strings)
+ `(concatenate 'string ,@strings))
+
+(defun assert-type (type val)
+ (assert (typep val type))
+ val)
+
+(defun clipnum (num min max)
+ (cond ((< num min) min)
+ ((> num max) max)
+ (t num)))
+
+(defmacro regex-cond (key &body clauses)
+ (let ((match (gensym))
+ (sub (gensym))
+ (val (gensym))
+ (block-nm (gensym)))
+ (flet ((ctrans (clause)
+ (if (eq (first clause) 'otherwise)
+ `(return-from ,block-nm
+ (progn ,@(rest clause)))
+ (destructuring-bind (regex arglist &body body)
+ clause
+ `(multiple-value-bind (,match ,sub)
+ (ppcre:scan-to-strings ,regex ,val)
+ ,@(if (null arglist)
+ `((declare (ignore ,sub))))
+ (if ,match
+ (return-from ,block-nm
+ (let ,(let ((argno 0))
+ (mapcar #'(lambda (arg)
+ (prog1 `(,arg (aref ,sub ,argno))
+ (incf argno)))
+ arglist))
+ ,@body))))))))
+ `(block ,block-nm
+ (let ((,val (the string ,key)))
+ ,@(mapcar #'ctrans clauses))))))
+
+;;; Error conditions
+(define-condition protocol-error (error)
+ ((message :reader protocol-error-message
+ :initarg :message
+ :type string)
+ (real-error :reader protocol-error-cause
+ :initarg :cause
+ :type condition
+ :initform nil)
+ (retries :reader protocol-error-retries
+ :initarg :retries
+ :type integer
+ :initform 0))
+ (:report (lambda (c s)
+ (if (protocol-error-cause c)
+ (format s "~A: ~A" (protocol-error-message c) (protocol-error-cause c))
+ (format s "Protocol error occurred on mpd socket: ~A" (protocol-error-message c))))))
+
+(define-condition protocol-input-error (protocol-error)
+ ((inputs :reader protocol-error-inputs
+ :initarg :inputs))
+ (:report (lambda (c s)
+ (apply #'format s (protocol-error-message c) (protocol-error-inputs c)))))
+
+(define-condition command-error (error)
+ ((err-code :reader command-error-code
+ :initarg :err-code
+ :type integer)
+ (message :reader command-error-message
+ :initarg :message
+ :type string))
+ (:report (lambda (c s)
+ (format s "mpd error response: ~A" (command-error-message c)))))
+
+(defvar *command-error-types* (make-hash-table))
+
+(defmacro def-command-error-type (code name desc)
+ (let ((cond-sym (intern (concat "COMMAND-ERROR-" (symbol-name name)))))
+ `(progn (define-condition ,cond-sym (command-error)
+ ()
+ (:report (lambda (c s)
+ (format s "mpd error response: ~A (message was: `~A')" ,desc (command-error-message c)))))
+ (setf (gethash ,code *command-error-types*) ',cond-sym)
+ (export '(,cond-sym)))))
+;; The following are fetched from libmpdclient.h. In all honesty, I
+;; can't really figure out what they mean just from their names, so
+;; the descriptions aren't optimal in every conceivable way.
+(def-command-error-type 1 not-list "not list")
+(def-command-error-type 2 arg "argument")
+(def-command-error-type 3 password "bad password")
+(def-command-error-type 4 permission "permission denied")
+(def-command-error-type 5 unknown-cmd "unknown command")
+(def-command-error-type 50 no-exist "item does not exist")
+(def-command-error-type 51 playlist-max "playlist overload") ; ?!
+(def-command-error-type 52 system "system error")
+(def-command-error-type 53 playlist-load "could not load playlist")
+(def-command-error-type 54 update-already "already updated") ; ?!
+(def-command-error-type 55 player-sync "player sync") ; ?!
+(def-command-error-type 56 exist "item already exists")
+
+(export '(protocol-error reconnect command-error
+ protocol-error-retries command-error-code
+ command-error-message))
+
+;;; Struct definitions
+(defstruct song
+ (file "" :type string)
+ (id -1 :type integer)
+ (pos -1 :type integer)
+ (length -1 :type integer)
+ (track -1 :type integer)
+ artist title album genre composer date)
+
+(export '(song
+ song-file song-id song-pos song-length song-track
+ song-artist song-title song-album song-genre
+ song-composer song-date))
+
+(defstruct status
+ (volume 0 :type integer)
+ (playlist-version -1 :type integer)
+ (num-songs 0 :type integer)
+ (song -1 :type integer)
+ (songid -1 :type integer)
+ (pos -1 :type integer)
+ (song-len -1 :type integer)
+ repeat repeat-song random state)
+
+;;; Basic protocol management
+#+sbcl (defmacro with-conn-lock (&body body)
+ `(sb-thread:with-recursive-lock (*conn-lock*) ,@body))
+#-sbcl (defmacro with-conn-lock (&body body)
+ body)
+
+(defun disconnect ()
+ "Disconnect from MPD."
+ (with-conn-lock
+ (let ((sk (prog1 *socket* (setf *socket* nil))))
+ (if sk (ignore-errors (close sk))))))
+
+(defun connection-error (condition-type &rest condition-args)
+ (disconnect)
+ (error (apply #'make-condition condition-type :retries *retries* condition-args)))
+
+(defun command-error (code message)
+ (error (funcall #'make-condition (gethash code *command-error-types* 'command-error)
+ :err-code code
+ :message message)))
+
+(defun get-response ()
+ (let ((ret '()) (last nil))
+ (loop (let ((line (handler-case
+ (read-line *socket*)
+ (error (err)
+ (connection-error 'protocol-error
+ :message "Socket read error"
+ :cause err)))))
+ (regex-cond line
+ ("^OK( .*)?$"
+ ()
+ (return ret))
+ ("^ACK \\[(\\d+)@(\\d+)\\] \\{([^\\}]*)\\} (.*)$"
+ (code list-pos command rest)
+ (declare (ignore list-pos command))
+ (command-error (parse-integer code) rest))
+ ("^([^:]+): (.*)$"
+ (key val)
+ (let ((new (list (cons (intern (string-upcase key) (find-package 'keyword))
+ val))))
+ (if last
+ (setf (cdr last) new last new)
+ (setf ret new last new))))
+ (otherwise
+ (connection-error 'protocol-input-error
+ :message "Invalid response from mpd: ~A"
+ :inputs (list line))))))))
+
+(defun connect (&key (host "localhost") (port 6600))
+ "Connect to a running MPD."
+ (disconnect)
+ (with-conn-lock
+ (setf *socket* (block outer
+ (let ((last-err nil))
+ (dolist (address (host-ent-addresses (get-host-by-name host)))
+ (handler-case
+ (let ((sk (make-instance 'inet-socket :type :stream)))
+ (socket-connect sk address port)
+ (return-from outer (socket-make-stream sk :input t :output t :buffering :none)))
+ (error (err)
+ (setf last-err err)
+ (warn "mpd connection failure on address ~A: ~A" address err))))
+ (if last-err
+ (error "Could not connect to mpd: ~A" last-err)
+ (error "Could not connect to mpd: host name `~A' did not resolve to any addreses" host)))))
+ (setf *last-server* (cons host port))
+ (setf *last-command* (get-universal-time))
+ (get-response)))
+
+(defmacro dovector ((var vec) &body body)
+ (let ((i (gensym)))
+ `(dotimes (,i (length ,vec))
+ (let ((,var (aref ,vec ,i)))
+ ,@body))))
+
+(defmacro with-push-vector ((push-fun type &key (init-length 16)) &body body)
+ (let ((vec (gensym)))
+ `(let ((,vec (make-array (list ,init-length) :element-type ',type :adjustable t :fill-pointer 0)))
+ (flet ((,push-fun (el)
+ (declare (type ,type el))
+ (vector-push-extend el ,vec)))
+ ,@body)
+ ,vec)))
+
+(defun quote-argument (arg)
+ (declare (type string arg))
+ (if (= (length arg) 0)
+ "\"\""
+ (let* ((quote nil)
+ (res (with-push-vector (add character)
+ (dovector (elt arg)
+ (case elt
+ ((#\space #\tab)
+ (setf quote t) (add elt))
+ ((#\")
+ (setf quote t) (add #\\) (add #\"))
+ ((#\newline)
+ (error "Cannot send strings containing newlines to mpd: ~S" arg))
+ (t (add elt)))))))
+ (if quote
+ (concat "\"" res "\"")
+ res))))
+
+(defun arg-to-string (arg)
+ (quote-argument
+ (typecase arg
+ (string arg)
+ (t (write-to-string arg :escape nil)))))
+
+(defun mpd-command (&rest words)
+ (with-conn-lock
+ (let ((*retries* 0))
+ (loop
+ (restart-case
+ (progn (if (null *socket*)
+ (connection-error 'protocol-error
+ :message "Not connected to mpd"))
+ (handler-case
+ (progn (write-string (reduce #'(lambda (a b) (concat a " " b))
+ (mapcar #'arg-to-string words))
+ *socket*)
+ (terpri *socket*)
+ (force-output *socket*))
+ (error (err)
+ (connection-error 'protocol-error
+ :message "Socket write error"
+ :cause err)))
+ (setf *last-command* (get-universal-time))
+ (return (get-response)))
+ (reconnect ()
+ :test (lambda (c) (and (typep c 'protocol-error) (not (null *last-server*))))
+ :report (lambda (s)
+ (format s "Reconnect to ~A:~D and try again (~D retries so far)" (car *last-server*) (cdr *last-server*) *retries*))
+ (incf *retries*)
+ (connect :host (car *last-server*)
+ :port (cdr *last-server*))))))))
+
+(export '(connect disconnect))
+
+;;; Slot parsers
+;; These, and the structures themselves, should probably be rewritten
+;; using macros instead. There's a lot of redundancy.
+(defun cons-status (info)
+ (let ((ret (make-status)))
+ (dolist (line info ret)
+ (handler-case
+ (case (car line)
+ ((:time)
+ (let ((pos (assert-type '(integer 0 *) (position #\: (cdr line)))))
+ (setf (status-pos ret) (parse-integer (subseq (cdr line) 0 pos))
+ (status-song-len ret) (parse-integer (subseq (cdr line) (1+ pos))))))
+ ((:state) (setf (status-state ret) (intern (string-upcase (cdr line)) (find-package 'keyword))))
+ ((:repeat) (setf (status-repeat ret) (not (equal (cdr line) "0"))))
+ ((:repeatsong) (setf (status-repeat-song ret) (not (equal (cdr line) "0"))))
+ ((:random) (setf (status-random ret) (not (equal (cdr line) "0"))))
+ ((:volume) (setf (status-volume ret) (parse-integer (cdr line))))
+ ((:playlistlength) (setf (status-num-songs ret) (parse-integer (cdr line))))
+ ((:song) (setf (status-song ret) (parse-integer (cdr line))))
+ ((:songid) (setf (status-songid ret) (parse-integer (cdr line))))
+ ((:playlist) (setf (status-playlist-version ret) (parse-integer (cdr line))))
+ ;; Ignored:
+ ((:xfade :bitrate :audio))
+ (t (warn "Unknown status slot ~A" (car line))))
+ (parse-error ()
+ (warn "Status slot parse error in ~S, slot was ~S" ret line))))))
+
+(defun song-list (info)
+ (let ((ret '()) (cur nil))
+ (dolist (line info ret)
+ (handler-case
+ (case (car line)
+ ((:file)
+ (setf cur (make-song :file (cdr line)))
+ (setf ret (nconc ret (list cur))))
+ ((:time) (setf (song-length cur) (parse-integer (cdr line))))
+ ((:id) (setf (song-id cur) (parse-integer (cdr line))))
+ ((:pos) (setf (song-pos cur) (parse-integer (cdr line))))
+ ((:track) (setf (song-track cur) (parse-integer (cdr line))))
+ ((:title) (setf (song-title cur) (cdr line)))
+ ((:album) (setf (song-album cur) (cdr line)))
+ ((:artist) (setf (song-artist cur) (cdr line)))
+ ((:genre) (setf (song-genre cur) (cdr line)))
+ ((:composer) (setf (song-composer cur) (cdr line)))
+ ((:date) (setf (song-date cur) (cdr line)))
+ (t (warn "Unknown song slot ~A" (car line))))
+ (parse-error ()
+ (warn "Song slot parse error in ~A, slot was ~A" cur line))))))
+
+;;; Functions for individual commands
+(defun status ()
+ "Fetch and return the current status of the MPD as a STATUS structure."
+ (cons-status (mpd-command "status")))
+
+(defmacro with-status (slots &body body)
+ "Fetch the current status of the MPD, and then run BODY with the
+variables in the SLOTS bound to their curresponding status items.
+Available slots are:
+
+ STATE (SYMBOL)
+ The current state of the MPD
+ Known values are :STOP, :PAUSE and :PLAY
+ VOLUME (INTEGER 0 100)
+ Current output volume
+ PLAYLIST-VERSION (INTEGER 0 *)
+ Increases by one each time the playlist changes
+ NUM-SONGS (INTEGER 0 *)
+ Number of songs in the playlist
+ SONG (INTEGER 0 NUM-SONGS)
+ Index, in the playlist, of the currently playing song
+ SONGID (INTEGER)
+ ID of the currently playing song
+ SONG-LEN (INTEGER 0 *)
+ Length, in seconds, of currently playing song
+ POS (INTEGER 0 SONG-LEN)
+ Current time position of the currently playing song, in seconds
+ REPEAT (NIL or T)
+ Non-NIL if the MPD is in repeat mode
+ REPEAT-SONG (NIL or T)
+ Non-NIL if the MPD is repeating the current song
+ (not available without patching)
+ RANDOM (NIL or T)
+ Non-NIL if the MPD is in random mode"
+ (let ((status (gensym "STATUS")))
+ `(let* ((,status (status))
+ ;; This is kinda ugly, but I don't really know any better
+ ;; way to do it with structs.
+ ,@(mapcar #'(lambda (slot-sym)
+ (let ((slot-fun (intern (concat "STATUS-" (symbol-name slot-sym))
+ (find-package 'mpcl))))
+ `(,slot-sym (,slot-fun ,status))))
+ slots))
+ ,@body)))
+
+(defun play-song (song)
+ "Switch to a new song. SONG can be either an integer, indicating the
+position in the playlist of the song to be played, or a SONG structure
+instance (as received from the PLAYLIST function, for example),
+reflecting the song to be played."
+ (etypecase song
+ (song (mpd-command "playid" (song-id song)))
+ (integer (mpd-command "play" song))))
+
+(defun next ()
+ "Go to the next song in the playlist."
+ (mpd-command "next"))
+
+(defun prev ()
+ "Go to the previous song in the playlist."
+ (mpd-command "previous"))
+
+(defun toggle-pause ()
+ "Toggle between the :PAUSE and :PLAY states. Has no effect if the
+MPD is in the :STOP state."
+ (mpd-command "pause"))
+
+(defun pause ()
+ "Pause the playback, but only in the :PLAY state."
+ (if (eq (status-state (status)) :play)
+ (toggle-pause)))
+
+(defun ping ()
+ "Ping the MPD, so as to keep connection open."
+ (mpd-command "ping"))
+
+(defun maybe-ping ()
+ "Ping the MPD, but only if more than 10 seconds have elapsed since a
+command was last sent to it."
+ (if (and *socket*
+ (> (- (get-universal-time) *last-command*) 10))
+ (progn (ping) t)
+ nil))
+
+(defun stop ()
+ "Stop playback."
+ (mpd-command "stop"))
+
+(defun play ()
+ "Start playback of the current song."
+ (mpd-command "play"))
+
+(defun current-song ()
+ "Returns a SONG structure instance reflecting the currently playing song."
+ (first (song-list (mpd-command "currentsong"))))
+
+(defun song-info (song-num)
+ "Returns a SONG structure instance describing the song with the
+number SONG-NUM in the playlist"
+ (declare (type (integer 0 *) song-num))
+ (first (song-list (mpd-command "playlistinfo" song-num))))
+
+(defun playlist ()
+ "Return a list of SONG structure instances, reflecting the songs in
+the current playlist."
+ (song-list (mpd-command "playlistinfo")))
+
+(defun search-song (type datum)
+ "Search the entire song database for songs matching DATUM. TYPE
+specifies what data to search among, and can be one of the following
+symbols:
+
+ :ARTIST
+ :ALBUM
+ :TITLE
+ :TRACK
+ :GENRE
+ :COMPOSER
+ :PERFORMER
+ :COMMENT
+
+This function returns a list of SONG instances describing the search
+results, but meaningful information in the ID and POS slots, whether
+or not the songs are actually part of the current playlist."
+ (song-list (mpd-command "search" (string-downcase (symbol-name type)) datum)))
+
+(defun search-playlist (type datum)
+ "Works like the SEARCH-SONG function, but limits the search to the
+currently loaded playlist, and will return meaningful ID and POS
+information. See the documentation for the SEARCH-SONG function for
+further information."
+ (song-list (mpd-command "playlistsearch" (string-downcase (symbol-name type)) datum)))
+
+(defun seek (sec &optional relative)
+ "Seek in the currently playing song. If RELATIVE is NIL (the
+default), seeks to SEC seconds from the start; otherwise, seeks to SEC
+seconds from the current position (may be negative)."
+ (with-status (songid pos)
+ (if relative
+ (setf sec (+ pos sec)))
+ (mpd-command "seekid" songid sec)))
+
+(defun set-volume (value &optional relative)
+ "Tells the MPD to change the audio system volume to VALUE, ranging
+from 0 to 100. If RELATIVE is non-NIL, change the current volume by
+VALUE (which may be negative) instead."
+ (mpd-command "setvol"
+ (clipnum (if relative
+ (with-status (volume)
+ (+ volume value))
+ value)
+ 0 100)))
+
+(export '(current-song song-info playlist status with-status ping maybe-ping
+ play-song next prev toggle-pause pause play stop seek set-volume
+ search-song search-playlist))
+(provide :mpcl)
Dolda2000 GitWeb / lisp-utils.git / commitdiff