1.1--- a/lisp/lib/aud/aud.asd Sun Apr 14 20:48:25 2024 -0400
1.2+++ b/lisp/lib/aud/aud.asd Mon Apr 15 22:17:19 2024 -0400
1.3@@ -3,7 +3,8 @@
1.4 :depends-on (:cl-ppcre :std :obj :dat :alsa :sndfile)
1.5 :version "0.1.0"
1.6 :serial t
1.7- :components ((:file "pkg"))
1.8+ :components ((:file "pkg")
1.9+ (:file "mpd"))
1.10 :in-order-to ((test-op (test-op "aud/tests"))))
1.11
1.12 (defsystem :aud/tests
2.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
2.2+++ b/lisp/lib/aud/mpd.lisp Mon Apr 15 22:17:19 2024 -0400
2.3@@ -0,0 +1,634 @@
2.4+;;; aud/mpd.lisp --- MPD Interface for Lisp
2.5+
2.6+;; based on https://github.com/stassats/mpd
2.7+
2.8+;;; Commentary:
2.9+
2.10+;; The original code hasn't been updated in quite some time. Here
2.11+;; we've added in some missing slots, fixed a typo, removed the
2.12+;; dependency on usocket library and extended the functionality
2.13+;; slightly.
2.14+
2.15+
2.16+;;; Code:
2.17+(in-package :aud/mpd)
2.18+;;; Classes
2.19+(define-condition mpd-error (error)
2.20+ ((text :initarg :text :reader text
2.21+ :initform nil))
2.22+ (:report (lambda (condition stream)
2.23+ (princ (text condition) stream))))
2.24+
2.25+(macrolet ((define-conditions (names)
2.26+ `(progn ,@(mapcar
2.27+ (lambda (name)
2.28+ `(define-condition ,name (mpd-error) ()))
2.29+ names))))
2.30+ (define-conditions (bad-argument incorrect-password
2.31+ not-permitted unknown-command not-exist
2.32+ playlist-size-exceed already-updating exist)))
2.33+
2.34+(defparameter *error-ids-alist*
2.35+ '((2 . bad-argument)
2.36+ (3 . incorrect-password)
2.37+ (4 . not-permitted)
2.38+ (5 . unknown-command)
2.39+ (50 . not-exist)
2.40+ (51 . playlist-size-exceed)
2.41+ (54 . already-updating)
2.42+ (56 . exist)))
2.43+
2.44+(eval-always
2.45+ (defparameter *tag-types*
2.46+ '(:artist :album :title :track :name :genre :date
2.47+ :composer :performer :comment :disc :filename :any)
2.48+ "Types of tags for using in `search' and `find'"))
2.49+
2.50+(deftype tag-type ()
2.51+ `(member ,@*tag-types*))
2.52+
2.53+(defclass track ()
2.54+ ((file
2.55+ :initform nil :initarg :file :accessor file)
2.56+ (title
2.57+ :initform nil :initarg :title :accessor title)
2.58+ (artist
2.59+ :initform nil :initarg :artist :accessor artist)
2.60+ (albumartist
2.61+ :initform nil :initarg :albumartist :accessor albumartist)
2.62+ (album
2.63+ :initform nil :initarg :album :accessor album)
2.64+ (genre
2.65+ :initform nil :initarg :genre :accessor genre)
2.66+ (date
2.67+ :initform nil :initarg :date :accessor date)
2.68+ (performer
2.69+ :initform nil :initarg :performer :accessor performer)
2.70+ (composer
2.71+ :initform nil :initarg :composer :accessor composer)
2.72+ (disc
2.73+ :initform nil :initarg :disc :accessor disc)
2.74+ (track
2.75+ :initform nil :initarg :track :accessor track-number)
2.76+ (time
2.77+ :initform nil :initarg :time :accessor duration)
2.78+ (last-modified
2.79+ :initform nil :initarg :last-modified :accessor last-modified)))
2.80+
2.81+(defclass playlist (track)
2.82+ ((pos
2.83+ :initform 0 :initarg :pos :accessor position-in-playlist
2.84+ :type integer)
2.85+ (duration
2.86+ :initform nil :initarg :duration)
2.87+ (format :initform nil :initarg :format)
2.88+ (id
2.89+ :initform 0 :initarg :id :accessor id
2.90+ :type integer)))
2.91+
2.92+(defclass status ()
2.93+ ((volume
2.94+ :reader volume :initarg :volume :initform nil)
2.95+ (repeat
2.96+ :reader repeat :initarg :repeat :initform nil)
2.97+ (random
2.98+ :reader randomized :initarg :random :initform nil)
2.99+ (playlist
2.100+ :reader playlist-version :initarg :playlist :initform nil)
2.101+ (playlist-length
2.102+ :reader playlist-length :initarg :playlistlength :initform nil)
2.103+ (xfade
2.104+ :reader xfade :initarg :xfade :initform nil)
2.105+ (state
2.106+ :reader state :initarg :state :initform nil)
2.107+ (partition
2.108+ :reader partition :initarg :partition :initform nil)
2.109+ (audio
2.110+ :reader audio :initarg :audio :initform nil)
2.111+ (bitrate
2.112+ :reader bitrate :initarg :bitrate :initform nil)
2.113+ (duration
2.114+ :reader duration :initarg :duration :initform nil)
2.115+ (time
2.116+ :reader %time :initarg :time :initform nil)
2.117+ (songid
2.118+ :reader songid :initarg :songid :initform nil)
2.119+ (song :reader song :initarg :song :initform nil)
2.120+ (nextsongid
2.121+ :reader nextsongid :initarg :nextsongid :initform nil)
2.122+ (nextsong
2.123+ :reader nextsong :initarg :nextsong :initform nil)
2.124+ (elapsed
2.125+ :reader elapsed :initarg :elapsed :initform nil)
2.126+ (mixrampdb
2.127+ :reader mixrampdb :initarg :mixrampdb :initform nil)
2.128+ (consume
2.129+ :reader consume :initarg :consume :initform nil)
2.130+ (single
2.131+ :reader single :initarg :single :initform nil)))
2.132+
2.133+(defclass stats ()
2.134+ ((artists
2.135+ :reader artists :initarg :artists :initform nil)
2.136+ (albums
2.137+ :reader albums :initarg :albums :initform nil)
2.138+ (songs
2.139+ :reader songs :initarg :songs :initform nil)
2.140+ (uptime
2.141+ :reader uptime :initarg :uptime :initform nil)
2.142+ (playtime
2.143+ :reader playtime :initarg :playtime :initform nil)
2.144+ (db-playtime
2.145+ :reader db-playtime :initarg :db_playtime :initform nil)
2.146+ (db-update
2.147+ :reader db-update :initarg :db_update :initform nil)))
2.148+
2.149+(macrolet ((generate-commands (class names)
2.150+ `(progn
2.151+ ,@(mapcar (lambda (name)
2.152+ `(defmethod ,name ((stream socket))
2.153+ (,name (,class stream))))
2.154+ names))))
2.155+ (generate-commands status
2.156+ (volume repeat randomized playlist-version playlist-length
2.157+ xfade state audio bitrate duration songid song))
2.158+ (generate-commands stats
2.159+ (artists albums songs uptime playtime db-playtime db-update)))
2.160+
2.161+(defparameter *integer-keys*
2.162+ '(:id :pos :volume :playlist :playlistlength
2.163+ :xfade :song :songid :bitrate :playtime
2.164+ :artists :albums :songs :uptime :db_playtime :db_update
2.165+ :outputid)
2.166+ "List of keys which values must be integers.")
2.167+
2.168+(defparameter *value-processing-functions*
2.169+ '(:time parse-time :state to-keyword
2.170+ :random string-not-zerop :repeat string-not-zerop
2.171+ :outputenabled string-not-zerop))
2.172+
2.173+(defmethod print-object ((object track) stream)
2.174+ (print-unreadable-object (object stream :type t :identity t)
2.175+ (with-slots (artist title album) object
2.176+ (format stream "~A - ~A (~A)" artist title album))))
2.177+
2.178+;;; MPD
2.179+(defvar *default-host* "localhost")
2.180+(defvar *default-port* 6600)
2.181+
2.182+(defun connect (&key (host *default-host*) (port *default-port*) password)
2.183+ "Connect to MPD."
2.184+ (let ((connection (socket-connect (make-instance 'inet-socket :type :stream) (get-address-by-name host) port)))
2.185+ (prog1 (values connection
2.186+ (read-answer (socket-make-stream connection :input t :output t)))
2.187+ (when password
2.188+ (password connection password)))))
2.189+
2.190+(defun read-answer (stream)
2.191+ (loop for line = (read-line stream)
2.192+ until (string= line "OK" :end1 2)
2.193+ collect line
2.194+ when (string= line "ACK" :end1 3)
2.195+ do (throw-error line)))
2.196+
2.197+(defun throw-error (text)
2.198+ ;; Error format: `ACK [<error id>@<position>] {<comand name>} <description>'
2.199+ (let* ((error-id (parse-integer text :start 5 :junk-allowed t))
2.200+ (delimiter (position #\] text))
2.201+ (condition (cdr (assoc error-id *error-ids-alist*))))
2.202+ (error condition :text (subseq text (+ delimiter 2)))))
2.203+
2.204+(defmacro with-mpd ((var &rest options) &body body)
2.205+ `(let ((,var (connect ,@options)))
2.206+ (unwind-protect
2.207+ (progn ,@body)
2.208+ (disconnect ,var))))
2.209+
2.210+(defun send-command (connection command)
2.211+ "Send command to MPD."
2.212+ (let ((stream (socket-make-stream connection :input t)))
2.213+ (unless (open-stream-p stream)
2.214+ (error 'mpd-error :text (format nil "The stream ~A is not opened." stream)))
2.215+ (write-line command stream)
2.216+ (finish-output stream)
2.217+ (read-answer stream)))
2.218+
2.219+;;; Parsing
2.220+
2.221+(defun to-keyword (name)
2.222+ (intern (string-upcase name) :keyword))
2.223+
2.224+(defun split-value (string)
2.225+ "Split a string `key: value' into (list :key value)."
2.226+ (let ((column (position #\: string)))
2.227+ (process-value (to-keyword (subseq string 0 column))
2.228+ (subseq string (+ 2 column)))))
2.229+
2.230+(defun split-values (strings)
2.231+ "Transform a list of strings 'key: value' into the plist."
2.232+ (mapcan #'split-value strings))
2.233+
2.234+(defun process-value (key value)
2.235+ (list key
2.236+ (funcall (value-processing-function key) value)))
2.237+
2.238+(defun value-processing-function (key)
2.239+ (if (member key *integer-keys*)
2.240+ #'parse-integer
2.241+ (getf *value-processing-functions* key #'identity)))
2.242+
2.243+(defun parse-time (time)
2.244+ "\"10:20\" -> (10 20); \"10\" -> 10"
2.245+ (multiple-value-bind (first stop)
2.246+ (parse-integer time :junk-allowed t)
2.247+ (if (= stop (length time))
2.248+ first
2.249+ (list first
2.250+ (parse-integer time :start (1+ stop))))))
2.251+
2.252+(defun string-not-zerop (string)
2.253+ (not (string= string "0")))
2.254+
2.255+(defun filter-keys (strings)
2.256+ "Transform a list of strings 'key: value' into a list of values."
2.257+ (mapcar (lambda (entry)
2.258+ (subseq entry (+ 2 (position #\: entry))))
2.259+ strings))
2.260+
2.261+(defun make-class (data type)
2.262+ "Make a new instance of the class playlist with initargs from
2.263+ the list of strings `key: value'."
2.264+ (apply 'make-instance type (split-values data)))
2.265+
2.266+(defun parse-list (list &optional class)
2.267+ "Make a list of new instances of the class `class' with initargs from
2.268+ a list of strings `key: value'. Each track is separeted by the `file' key."
2.269+ (let (track)
2.270+ (flet ((create-track ()
2.271+ (when track
2.272+ (list (apply 'make-instance class track)))))
2.273+ (nconc
2.274+ (mapcan (lambda (x)
2.275+ (let ((pair (split-value x)))
2.276+ (case (car pair)
2.277+ (:file (prog1 (create-track)
2.278+ (setf track pair)))
2.279+ ((:directory :playlist)
2.280+ (list pair))
2.281+ (t (nconc track pair)
2.282+ nil))))
2.283+ list)
2.284+ (create-track)))))
2.285+
2.286+;;;
2.287+
2.288+(defun process-string (string)
2.289+ "Check for emtpy strings, and escape strings when needed."
2.290+ (when string
2.291+ (let ((string
2.292+ (string-trim '(#\Space #\Tab #\Newline) string)))
2.293+ (when (zerop (length string))
2.294+ (error 'mpd-error :text "Zero length argument."))
2.295+ (if (position #\Space string)
2.296+ (prin1-to-string string)
2.297+ string))))
2.298+
2.299+;;; Macros
2.300+
2.301+(defmacro send (&rest commands)
2.302+ "Macro for using inside `defcommand'."
2.303+ `(send-command connection
2.304+ (format nil "~{~A~^ ~}"
2.305+ (remove nil (list ,@commands)))))
2.306+
2.307+(defmacro defcommand (name parameters &body body)
2.308+ `(defun ,name (connection ,@parameters)
2.309+ ,@body))
2.310+
2.311+(defmacro defmethod-command (name parameters &body body)
2.312+ `(defmethod ,name (connection ,@parameters)
2.313+ ,@body))
2.314+
2.315+(defmacro check-args (type &rest args)
2.316+ "Check string and integer arguments."
2.317+ (if (or (eq type 'string)
2.318+ (and (listp type)
2.319+ (member 'string type)))
2.320+ `(progn ,@(mapcan
2.321+ (lambda (arg)
2.322+ `((check-type ,arg ,type "a string")
2.323+ (setf ,arg (process-string ,arg))))
2.324+ args))
2.325+ `(progn ,@(mapcar
2.326+ (lambda (arg)
2.327+ `(check-type ,arg ,type))
2.328+ args))))
2.329+
2.330+;;; Commands
2.331+(defcommand password (password)
2.332+ "Authentication."
2.333+ (check-args string password)
2.334+ (send "password" password))
2.335+
2.336+(defcommand disconnect ()
2.337+ "Close connection."
2.338+ (socket-close connection))
2.339+
2.340+(defcommand now-playing ()
2.341+ "Return instance of playlist with current song."
2.342+ (let ((track (send "currentsong")))
2.343+ (when track
2.344+ (make-class track 'playlist))))
2.345+
2.346+(defcommand disable-output (id)
2.347+ (check-args unsigned-byte id)
2.348+ (send "disableoutput" id))
2.349+
2.350+(defcommand enable-output (id)
2.351+ (check-args unsigned-byte id)
2.352+ (send "enableoutput" id))
2.353+
2.354+(defcommand ping ()
2.355+ "Send ping to MPD."
2.356+ (send "ping"))
2.357+
2.358+(defcommand kill ()
2.359+ "Stop MPD in a safe way."
2.360+ (send "kill"))
2.361+
2.362+(defcommand status ()
2.363+ "Return status of MPD."
2.364+ (make-class (send "status") 'status))
2.365+
2.366+(defcommand stats ()
2.367+ "Return statisics."
2.368+ (make-class (send "stats") 'stats))
2.369+
2.370+(defcommand outputs ()
2.371+ "Return information about all outputs."
2.372+ (split-values (send "outputs")))
2.373+
2.374+(defcommand commands ()
2.375+ "Return list of available commands."
2.376+ (filter-keys (send "commands")))
2.377+
2.378+(defcommand not-commands ()
2.379+ "Return list of commands to which the current user does not have access."
2.380+ (filter-keys
2.381+ (send "notcommands")))
2.382+
2.383+;;; Control
2.384+
2.385+(defcommand pause ()
2.386+ "Toggle pause / resume playing."
2.387+ (send "pause"))
2.388+
2.389+(defcommand play (&optional song-number)
2.390+ (check-args (or unsigned-byte null) song-number)
2.391+ "Begin playing the playlist starting from song-number, default is 0."
2.392+ (send "play" song-number))
2.393+
2.394+(defcommand stop ()
2.395+ "Stop playing."
2.396+ (send "stop"))
2.397+
2.398+(defcommand next ()
2.399+ "Play next track in the playlist."
2.400+ (send "next"))
2.401+
2.402+(defcommand previous ()
2.403+ "Play previous track in the playlist."
2.404+ (send "previous"))
2.405+
2.406+(defcommand crossfade (seconds)
2.407+ (check-args unsigned-byte seconds)
2.408+ "Sets crossfading between songs."
2.409+ (send "crossfade" seconds))
2.410+
2.411+;; Playlist
2.412+
2.413+(defcommand list-playlist (name)
2.414+ "List files in the playlist `name'"
2.415+ (check-args string name)
2.416+ (filter-keys (send "listplaylist" name)))
2.417+
2.418+(defcommand list-playlist-info (name)
2.419+ "List metadata of tracks in the playlist `name'"
2.420+ (check-args string name)
2.421+ (parse-list (send "listplaylistinfo" name) 'playlist))
2.422+
2.423+(defcommand clear ()
2.424+ "Clear the current playlist."
2.425+ (send "clear"))
2.426+
2.427+(defcommand save-playlist (filename)
2.428+ "Save the current playlist to the file in the playlist directory."
2.429+ (check-args string filename)
2.430+ (send "save" filename))
2.431+
2.432+(defcommand load-playlist (filename)
2.433+ "Load playlist from file."
2.434+ (check-args string filename)
2.435+ (send "load" filename))
2.436+
2.437+(defcommand rename-playlist (name new-name)
2.438+ "Rename playlist."
2.439+ (check-args string name new-name)
2.440+ (unless (equal name new-name)
2.441+ (send "rename" name new-name)))
2.442+
2.443+(defcommand playlist-info (&optional id)
2.444+ "Return content of the current playlist."
2.445+ (check-args (or unsigned-byte null) id)
2.446+ (if id
2.447+ (make-class (send "playlistinfo" id) 'playlist)
2.448+ (parse-list (send "playlistinfo") 'playlist)))
2.449+
2.450+(defcommand playlist-changes (version)
2.451+ "Return changed songs currently in the playlist since `version'."
2.452+ (check-args unsigned-byte version)
2.453+ (parse-list (send "plchanges" version) 'playlist))
2.454+
2.455+(defcommand add-to-playlist (name path)
2.456+ "Add `path' to the playlist `name'."
2.457+ (check-args string name path)
2.458+ (send "playlistadd" name path))
2.459+
2.460+(defcommand clear-playlist (name)
2.461+ "Clear playlist `name'."
2.462+ (check-args string name)
2.463+ (send "playlistclear"))
2.464+
2.465+(defcommand delete-from-playlist (name song-id)
2.466+ "Delete `song-id' from playlist `name'."
2.467+ (check-args string name)
2.468+ (check-args unsigned-byte song-id)
2.469+ (send "playlistdelete" name song-id))
2.470+
2.471+(defcommand move-in-playlist (name song-id position)
2.472+ "Move `song-id' in playlist `name' to `position'."
2.473+ (check-args string name)
2.474+ (check-args unsigned-byte song-id position)
2.475+ (send "playlistmove" name song-id position))
2.476+
2.477+(defcommand find-in-current-playlist (scope query)
2.478+ "Search for songs in the current playlist with strict matching."
2.479+ (check-args string scope query)
2.480+ (send "playlistfind" scope query))
2.481+
2.482+(defcommand search-in-current-playlist (scope query)
2.483+ "Search case-insensitively with partial matches for songs in the current playlist"
2.484+ (check-args string scope query)
2.485+ (send "playlistsearch" scope query))
2.486+
2.487+(defgeneric add (connection what)
2.488+ (:documentation "Add file or directory to the current playlist."))
2.489+
2.490+(defmethod-command add ((what track))
2.491+ (add connection (file what)))
2.492+
2.493+(defmethod-command add ((what string))
2.494+ (check-args string what)
2.495+ (send "add" what))
2.496+
2.497+(defgeneric add-id (connection what)
2.498+ (:documentation "Like add, but returns a id."))
2.499+
2.500+(defmethod-command add-id ((what track))
2.501+ (add connection (file what)))
2.502+
2.503+(defmethod-command add-id ((what string))
2.504+ (check-args string what)
2.505+ (car (filter-keys (send "addid" what))))
2.506+
2.507+(defcommand move (from to)
2.508+ "Move track from `from' to `to' in the playlist."
2.509+ (check-args unsigned-byte from to)
2.510+ (unless (= from to)
2.511+ (send "move" from to)))
2.512+
2.513+(defgeneric move-id (connection id to)
2.514+ (:documentation "Move track with `id' to `to' in the playlist."))
2.515+
2.516+(defmethod-command move-id ((track playlist) (to integer))
2.517+ (move-id connection (id track) to))
2.518+
2.519+(defmethod-command move-id ((id integer) (to integer))
2.520+ (check-args unsigned-byte id to)
2.521+ (send "moveid" id to))
2.522+
2.523+(defcommand swap (first second)
2.524+ "Swap positions of two tracks."
2.525+ (check-args unsigned-byte first second)
2.526+ (unless (= first second)
2.527+ (send "swap" first second)))
2.528+
2.529+(defgeneric swap-id (connection first second)
2.530+ (:documentation "Swap positions of two tracks by id."))
2.531+
2.532+(defmethod-command swap-id ((first playlist) (second playlist))
2.533+ (swap-id connection (id first) (id second)))
2.534+
2.535+(defmethod-command swap-id ((first integer) (second integer))
2.536+ (check-args unsigned-byte first second)
2.537+ (send "swap" first second))
2.538+
2.539+(defcommand delete-track (number)
2.540+ "Delete track from playlist."
2.541+ (check-args unsigned-byte number)
2.542+ (send "delete" number))
2.543+
2.544+(defgeneric delete-id (connection id)
2.545+ (:documentation "Delete track with `id' from playlist."))
2.546+
2.547+(defmethod-command delete-id ((id playlist))
2.548+ (delete-id connection (id id)))
2.549+
2.550+(defmethod-command delete-id ((id integer))
2.551+ (check-args unsigned-byte id)
2.552+ (send "deleteid" id))
2.553+
2.554+(defcommand shuffle ()
2.555+ "Shuffle the current playlist."
2.556+ (send "shuffle"))
2.557+
2.558+;;; Database
2.559+
2.560+(defcommand update (&optional path)
2.561+ "Scan directory for music files and add them to the database."
2.562+ (check-args string path)
2.563+ (send "update" path))
2.564+
2.565+(defcommand find-tracks (type what)
2.566+ "Find tracks in the database with a case sensitive, exact match."
2.567+ (check-args tag-type type)
2.568+ (check-args string what)
2.569+ (parse-list (send "find" type what) 'track))
2.570+
2.571+(defcommand list-metadata (metadata-1 &optional metadata-2 search-term)
2.572+ "List all metadata of `metadata-1'.
2.573+If `metadata-2' & `search-term' are supplied,
2.574+then list all `metadata-1' in which `metadata-2' has value `search-term'."
2.575+ (check-args (or string null) search-term)
2.576+ (send "list" metadata-1 metadata-2 search-term))
2.577+
2.578+(defcommand search-tracks (type what)
2.579+ "Find tracks in the database with a case sensitive, inexact match."
2.580+ (check-args tag-type type)
2.581+ (check-args string what)
2.582+ (parse-list (send "search" type what) 'track))
2.583+
2.584+(defcommand list-all-info (&optional path)
2.585+ "Lists all information about files in `path' recursively. Default path is /."
2.586+ (parse-list (send "listallinfo" path) 'track))
2.587+
2.588+(defcommand list-all (&optional path)
2.589+ "Lists all files in `path' recursively. Default path is /."
2.590+ (check-args (or string null) path)
2.591+ (filter-keys (send "listall" path)))
2.592+
2.593+(defcommand list-info (&optional path)
2.594+ "Show contents of directory."
2.595+ (check-args (or string null) path)
2.596+ (parse-list (send "lsinfo" path) 'track))
2.597+
2.598+(defcommand count-tracks (scope query)
2.599+ "Number of songs and their total playtime matching `query'.
2.600+Return: (number playtime)."
2.601+ (check-args string query)
2.602+ (filter-keys (send "count" scope query)))
2.603+
2.604+(defcommand tag-types ()
2.605+ "Get a list of available metadata types."
2.606+ (filter-keys (send "tagtypes")))
2.607+
2.608+(defcommand url-handlers ()
2.609+ "Get a list of available URL handlers."
2.610+ (filter-keys (send "urlhandlers")))
2.611+
2.612+(defun (setf volume) (value connection)
2.613+ "Set the volume to the value between 0-100."
2.614+ (check-type value (integer 0 100) "an integer in range 0-100")
2.615+ (send "setvol" value))
2.616+
2.617+(defun (setf randomized) (value connection)
2.618+ "NIL---turn off random mode, non-nil---turn on random mode."
2.619+ (send "random" (if value 1 0)))
2.620+
2.621+(defun (setf repeat) (value connection)
2.622+ "NIL---turn off repeat mode, non-nil---turn on repeat mode."
2.623+ (send "repeat" (if value 1 0)))
2.624+
2.625+(defcommand seek (song time)
2.626+ "Skip to a specified point in a song on the playlist."
2.627+ (send "seek" song time))
2.628+
2.629+(defgeneric seek-id (connection song time)
2.630+ (:documentation "Skip to a specified point in a song on the playlist."))
2.631+
2.632+(defmethod-command seek-id ((song playlist) (time integer))
2.633+ (seek-id connection (id song) time))
2.634+
2.635+(defmethod-command seek-id ((song integer) (time integer))
2.636+ (check-args unsigned-byte song time)
2.637+ (send "seekid" song time))
3.1--- a/lisp/lib/aud/pkg.lisp Sun Apr 14 20:48:25 2024 -0400
3.2+++ b/lisp/lib/aud/pkg.lisp Mon Apr 15 22:17:19 2024 -0400
3.3@@ -1,4 +1,121 @@
3.4 (defpackage :aud
3.5 (:use :cl :std :dat/midi :obj/music :sndfile :alsa))
3.6
3.7+(defpackage :aud/mpd
3.8+ (:use :cl :std :sb-bsd-sockets :net/core :net/util)
3.9+ (:nicknames :mpd)
3.10+ (:export
3.11+ :*default-host*
3.12+ :*default-port*
3.13+ :connect
3.14+ :disconnect
3.15+ :password
3.16+ :with-mpd
3.17+ :disable-output
3.18+ :enable-output
3.19+ :outputs
3.20+
3.21+ :ping
3.22+ :kill
3.23+ :status
3.24+
3.25+ :now-playing
3.26+ :pause
3.27+ :play
3.28+ :stop
3.29+ :previous
3.30+ :next
3.31+ :crossfade
3.32+
3.33+ :add
3.34+ :add-id
3.35+ :move
3.36+ :move-id
3.37+ :swap
3.38+ :swap-id
3.39+ :clear
3.40+ :delete-track
3.41+ :delete-id
3.42+ :save-playlist
3.43+ :load-playlist
3.44+ :rename-playlist
3.45+ :playlist-info
3.46+ :playlist-changes
3.47+ :shuffle
3.48+ :list-playlist
3.49+ :list-playlist-info
3.50+ :add-to-playlist
3.51+ :clear-playlist
3.52+ :delete-from-playlist
3.53+ :move-in-playlist
3.54+ :find-in-current-playlist
3.55+ :search-in-current-playlist
3.56+
3.57+ :update
3.58+
3.59+ :list-all
3.60+ :list-info
3.61+ :list-all-info
3.62+ :find-tracks
3.63+ :search-tracks
3.64+ :list-metadata
3.65+ :count-tracks
3.66+
3.67+ :commands
3.68+ :not-commands
3.69+ :tag-types
3.70+ :url-handlers
3.71+
3.72+ :playlist
3.73+ :track
3.74+ :file
3.75+ :title
3.76+ :artist
3.77+ :albumartist
3.78+ :album
3.79+ :date
3.80+ :genre
3.81+ :composer
3.82+
3.83+ :position-in-playlist
3.84+ :id
3.85+
3.86+ :mpd-error
3.87+ :protocol-mismatch
3.88+ :bad-argument
3.89+ :incorrect-password
3.90+ :not-permitted
3.91+ :unknown-command
3.92+ :not-exist
3.93+ :playlist-size-exceed
3.94+ :already-updating
3.95+ :exist
3.96+
3.97+ :volume
3.98+ :repeat
3.99+ :randomized
3.100+ :playlist-version
3.101+ :playlist-length
3.102+ :xfade
3.103+ :state
3.104+ :audio
3.105+ :bitrate
3.106+ :duration
3.107+ :songid
3.108+ :song
3.109+ :nextsongid
3.110+ :nextsong
3.111+ :elapsed
3.112+ :mixrampdb
3.113+ :consume
3.114+ :single
3.115+
3.116+ :artists
3.117+ :albums
3.118+ :songs
3.119+ :uptime
3.120+ :playtime
3.121+ :db-playtime
3.122+ :db-update))
3.123+
3.124 (in-package :aud)
4.1--- a/lisp/lib/cli/clap.lisp Sun Apr 14 20:48:25 2024 -0400
4.2+++ b/lisp/lib/cli/clap.lisp Mon Apr 15 22:17:19 2024 -0400
4.3@@ -3,7 +3,7 @@
4.4 ;;
4.5
4.6 ;;; Code:
4.7-(in-package :cli)
4.8+(in-package :cli/clap)
4.9
4.10 (defun cli-arg0 () (car sb-ext:*posix-argv*))
4.11 (defun cli-args () (cdr sb-ext:*posix-argv*))
4.12@@ -32,16 +32,20 @@
4.13 ;; "A handler which can be used to invoke the `discard-argument' restart"
4.14 ;; (invoke-restart (find-restart 'discard-argument condition)))
4.15
4.16+(defvar *no-exit* nil
4.17+ "Indicate whether the WITH-CLI-HANDLERS form should exit on completion.")
4.18+
4.19 (defmacro with-cli-handlers (form)
4.20 "A wrapper which handles common cli errors that may occur during
4.21 evaluation of FORM."
4.22 `(handler-case ,form
4.23 (sb-sys:interactive-interrupt ()
4.24 (format *error-output* "~&(:SIGINT)~&")
4.25- (sb-ext:exit :code 130))
4.26+ (unless *no-exit* (sb-ext:exit :code 130)))
4.27 (error (c)
4.28 (format *error-output* "~&~A~&" c)
4.29- (sb-ext:exit :code 1))))
4.30+ (error c)
4.31+ (unless *no-exit* (sb-ext:exit :code 1)))))
4.32
4.33 (defmacro with-cli (slots cli &body body)
4.34 "Like with-slots with some extra bindings."
5.1--- a/lisp/lib/cli/pkg.lisp Sun Apr 14 20:48:25 2024 -0400
5.2+++ b/lisp/lib/cli/pkg.lisp Mon Apr 15 22:17:19 2024 -0400
5.3@@ -100,6 +100,7 @@
5.4 (:shadowing-import-from :sb-ext :exit)
5.5 (:export
5.6 :*argv*
5.7+ :*no-exit*
5.8 :init-args
5.9 :cli-arg0
5.10 :cli-args
6.1--- a/lisp/lib/io/pkg.lisp Sun Apr 14 20:48:25 2024 -0400
6.2+++ b/lisp/lib/io/pkg.lisp Mon Apr 15 22:17:19 2024 -0400
6.3@@ -15,19 +15,24 @@
6.4 (defpackage :io
6.5 (:use :cl :std :obj/id :uring :sb-bsd-sockets)
6.6 (:import-from :sb-alien :addr)
6.7- (:import-from :uring :build))
6.8+ (:import-from :uring :build)
6.9+ (:shadowing-import-from :uring :load-uring)
6.10+ (:export :load-uring :*io*
6.11+ :init-io :enter-io :exit-io))
6.12
6.13 (in-package :io)
6.14
6.15-#+uring (load-uring)
6.16+(load-uring)
6.17
6.18-(defun init-io-uring (&optional (entries 256) (flags 0))
6.19+(defvar *io* nil)
6.20+
6.21+(defun init-io (&optional (entries 256) (flags 0))
6.22 "Initialize the *IO* variable to an io-uring alien-value type using a
6.23 queue size of ENTRIES and settings FLAGS."
6.24 (with-new-io-uring r
6.25 (if (= 0 (io-uring-queue-init entries (addr r) flags))
6.26- r
6.27+ (setf *io* r)
6.28 (error "failed to initialize io-uring"))))
6.29
6.30-(defun enter-io-uring (ring))
6.31-(defun exit-io-uring (ring))
6.32+(defun enter-io (ring))
6.33+(defun exit-io (ring))
7.1--- a/lisp/lib/log/err.lisp Sun Apr 14 20:48:25 2024 -0400
7.2+++ b/lisp/lib/log/err.lisp Mon Apr 15 22:17:19 2024 -0400
7.3@@ -3,5 +3,5 @@
7.4 ;;; Code:
7.5 (in-package :log)
7.6
7.7-(define-condition log-error (std-error simple-error program-error) ()
7.8- (:documentation "Base class for all LOG errors"))
7.9+(deferror log-error (std-error simple-error program-error) ()
7.10+ (:documentation "Base class for all LOG-related errors."))
8.1--- a/lisp/lib/log/log.lisp Sun Apr 14 20:48:25 2024 -0400
8.2+++ b/lisp/lib/log/log.lisp Mon Apr 15 22:17:19 2024 -0400
8.3@@ -1,15 +1,25 @@
8.4 (in-package :log)
8.5
8.6-(deftype log-level-designator () '(member :warn :debug :info :trace))
8.7-(declaim (type (or boolean log-level-designator) *log-level*))
8.8-(defvar *log-level* nil)
8.9+(deftype log-level-designator () '(member nil :fatal :error :warn :info :debug :trace t))
8.10+
8.11+(declaim (log-level-designator *log-level*))
8.12+(defvar *log-level* :debug
8.13+ "Logging is performed dynamically based on this variable. When NIL,
8.14+logging is disabled, which is equivalent to a level of :FATAL. When T,
8.15+Logging is enabled for all levels, which is equivalent to :TRACE.")
8.16+
8.17 (defvar *logger* nil)
8.18+
8.19 (defvar *log-router* nil)
8.20-(declaim (type (or boolean function number) *log-timestamp*))
8.21+
8.22 (defvar *log-timestamp* t
8.23 "If non-nil, print a timestamp with log output. The value may be a
8.24 function in which case it is used as the function value of
8.25-`log-timestamp-source'.")
8.26+`log-timestamp-source', or a number which will be used as the input arg to GET-REAL-TIME-SINCE.")
8.27+
8.28+(declaim (fixnum *log-indent*))
8.29+(defvar *log-indent* 0
8.30+ "Level of indentation to apply to multi-line log messages.")
8.31
8.32 (defun get-real-time-since (n)
8.33 "Return the numbers of seconds since a relative value offset N."
8.34@@ -23,40 +33,55 @@
8.35 (defun log-timestamp-source ()
8.36 (typecase *log-timestamp*
8.37 (function (funcall *log-timestamp*))
8.38- (number (format nil "~f" (/ (get-real-time-since *log-timestamp*) #.internal-time-units-per-second)))
8.39- (t (format nil "~f" (/ (get-internal-real-time) #.internal-time-units-per-second)))))
8.40+ (number (/ (get-real-time-since *log-timestamp*) #.internal-time-units-per-second))
8.41+ (t (/ (get-internal-real-time) #.internal-time-units-per-second))))
8.42
8.43+(defun universal-timestamp () (get-universal-time))
8.44+
8.45 ;; the purpose of this struct is to route log messages to the
8.46 ;; appropriate output stream. It should be configured and bound to
8.47 ;; *LOG-ROUTER*.
8.48 (defstruct log-router
8.49- info error debug trace)
8.50+ fatal error warn info debug trace)
8.51
8.52 ;; TODO 2023-09-20: make-synonym-stream, make-synonym-stream-symbol
8.53 (defvar *default-log-router*
8.54- (make-log-router :info *terminal-io*
8.55- :error *error-output*
8.56- :debug *debug-io*
8.57- :trace *trace-output*))
8.58+ (make-log-router
8.59+ :fatal *error-output*
8.60+ :error *error-output*
8.61+ :warn *debug-io*
8.62+ :info *terminal-io*
8.63+ :debug *debug-io*
8.64+ :trace *trace-output*))
8.65
8.66 (defstruct logger
8.67- (active nil :type boolean)
8.68- (timestamp *log-timestamp* :type (or boolean function))
8.69+ "The logger is responsible for intercepting log messages and either
8.70+printing them to a stream based on the router slot, or doing nothing
8.71+based on the level slot. Additionally, the appenders slot may contain
8.72+a list of functions taking a single log message as input. Each
8.73+appender in the list is called on each message intercepted wrt level."
8.74+ (level *log-level* :type log-level-designator)
8.75+ (timestamp *log-timestamp* :type (or boolean function number))
8.76+ (appenders nil :type list)
8.77 (router *default-log-router* :type log-router))
8.78
8.79 ;; TODO: (defmacro generate-log-profile)
8.80 ;; (defmacro deflogger) ;; yalog
8.81 ;; (defmacro with-log-profile)
8.82-;; (defmacro with-logger)
8.83+(defmacro with-logger ((logger) &body body)
8.84+ "Activate the specified logger for the life-time of BODY. This is
8.85+useful if you don't want to dynamically overwrite the *LOGGER*
8.86+binding."
8.87+ `(let ((*logger* ,logger))
8.88+ ,@body))
8.89+
8.90 (defmacro define-log-level (name)
8.91 (let ((%name (string-upcase name)))
8.92 `(progn
8.93 (defun ,(intern (concatenate 'string %name "!")) (&rest args)
8.94- (format t "#:~(~A~) ~A "
8.95+ (format t "#:~(~A~) ~@[~f~]"
8.96 ',name
8.97- (if *log-timestamp*
8.98- (log-timestamp-source)
8.99- ""))
8.100+ (when *log-timestamp* (log-timestamp-source)))
8.101 (mapc (lambda (x) (format t "; ~A~%" x)) args)
8.102 (if (= 1 (length args))
8.103 (car args)
8.104@@ -66,23 +91,12 @@
8.105 (defun ,(intern (concatenate 'string %name "-DESCRIBE")) (&rest args)
8.106 (,(intern (concatenate 'string %name "!")) (apply #'describe args))))))
8.107
8.108+(define-log-level fatal)
8.109 (define-log-level info)
8.110 (define-log-level trace)
8.111 (define-log-level warn)
8.112 (define-log-level debug)
8.113
8.114-#+nil (test! "foo")
8.115-
8.116-;; (defmacro info! (opts &rest args))
8.117-
8.118-;; (defmacro trace! (opts &rest args))
8.119-
8.120-;; (defmacro warn! (opts &rest args))
8.121-
8.122-;; (defun debug-p ()
8.123-;; (or (eq *log-level* t)
8.124-;; (eq *log-level* :debug)))
8.125-
8.126 ;; TODO 2023-08-31: single format control string
8.127 ;; (defun debug! (&rest args)
8.128 ;; (when (debug-p)
8.129@@ -90,7 +104,3 @@
8.130 ;; ;; RESEARCH 2023-08-31: what's better here.. loop, do, mapc+nil?
8.131 ;; (map nil (lambda (x) (format t "~X~%" x)) args))
8.132 ;; args)
8.133-
8.134-;; (defun debug-describe (&rest args)
8.135-;; (debug! (apply #'describe args)))
8.136-
9.1--- a/lisp/lib/log/pkg.lisp Sun Apr 14 20:48:25 2024 -0400
9.2+++ b/lisp/lib/log/pkg.lisp Mon Apr 15 22:17:19 2024 -0400
9.3@@ -26,8 +26,10 @@
9.4 (defpackage :log
9.5 (:use :cl :std)
9.6 (:export :*log-level* :*log-router* :*logger*
9.7+ :*default-log-router* :log-router :make-log-router :log-router-p
9.8 :get-real-time-since :init-log-timestamp
9.9 :*log-timestamp* :log-level-designator :log-timestamp-source :logger
9.10+ :logger-p :make-logger :log-error
9.11 :define-log-level :log! :warn! :info! :debug! :trace!
9.12 :log-p :warn-p :info-p :debug-p :trace-p
9.13 :log-describe :warn-describe :info-describe :debug-describe :trace-describe))
10.1--- a/lisp/lib/net/net.asd Sun Apr 14 20:48:25 2024 -0400
10.2+++ b/lisp/lib/net/net.asd Mon Apr 15 22:17:19 2024 -0400
10.3@@ -15,6 +15,7 @@
10.4 (:file "err")
10.5 (:file "obj")
10.6 (:file "sans-io")
10.7+ (:file "util")
10.8 (:file "udp")
10.9 (:file "tcp")
10.10 (:module "codec"
11.1--- a/lisp/lib/net/pkg.lisp Sun Apr 14 20:48:25 2024 -0400
11.2+++ b/lisp/lib/net/pkg.lisp Mon Apr 15 22:17:19 2024 -0400
11.3@@ -16,6 +16,10 @@
11.4 :proxy
11.5 :tunnel))
11.6
11.7+(defpackage :net/util
11.8+ (:use :cl :obj :dat/proto :std :log :net/core :sb-bsd-sockets)
11.9+ (:export :get-address-by-name))
11.10+
11.11 (defpackage :net/sans-io
11.12 (:use :cl :obj :dat/proto :std :net/core :sb-bsd-sockets)
11.13 (:export))
12.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
12.2+++ b/lisp/lib/net/util.lisp Mon Apr 15 22:17:19 2024 -0400
12.3@@ -0,0 +1,12 @@
12.4+(in-package :net/util)
12.5+
12.6+(defun get-address-by-name (name)
12.7+ (multiple-value-bind (host4 host6)
12.8+ (get-host-by-name name)
12.9+ (let ((addr4 (when host4
12.10+ (car (sb-bsd-sockets::host-ent-addresses host4))))
12.11+ (addr6 (when host6
12.12+ (car (sb-bsd-sockets::host-ent-addresses host6)))))
12.13+ (values addr4 addr6))))
12.14+
12.15+;; (get-address-by-name "localhost")
13.1--- a/lisp/lib/obj/db/mop.lisp Sun Apr 14 20:48:25 2024 -0400
13.2+++ b/lisp/lib/obj/db/mop.lisp Mon Apr 15 22:17:19 2024 -0400
13.3@@ -1,6 +1,25 @@
13.4+;;; obj/meta/store.lisp --- Storable MOPs
13.5+
13.6+;; The storable-class can be assigned to the :metaclass option of a
13.7+;; class to allow persistent storage of an object on disk. The
13.8+;; storable-slot-mixin is a custom slot option which can be used to
13.9+;; selectively enable slot serialization.
13.10+
13.11+;;; Commentary:
13.12+
13.13+;; This code is derived from XDB.
13.14+
13.15+;; Note that this is not a general purpose de/serializer. It is
13.16+;; specifically designed to decode/encode objects as single
13.17+;; octet-vectors from/to an open stream with minimal overhead. There
13.18+;; is a separate interface for general-purpose data encoding which can
13.19+;; be found in the DAT system.
13.20+
13.21+;;; Code:
13.22 (in-package :obj/db)
13.23
13.24 (sb-ext:unlock-package :sb-pcl)
13.25+
13.26 ;;; MOP
13.27 (defclass storable-class (standard-class)
13.28 ((class-id :initform nil
13.29@@ -18,6 +37,7 @@
13.30 :initform (make-hash-table :size 1000)
13.31 :accessor id-cache)))
13.32
13.33+;;; Initialize
13.34 (defun initialize-storable-class (next-method class &rest args
13.35 &key direct-superclasses &allow-other-keys)
13.36 (apply next-method class
13.37@@ -34,8 +54,7 @@
13.38 &rest args)
13.39 (apply #'initialize-storable-class #'call-next-method class args))
13.40
13.41-;;;
13.42-
13.43+;;; Validate
13.44 (defmethod validate-superclass
13.45 ((class standard-class)
13.46 (superclass storable-class))
13.47@@ -46,6 +65,7 @@
13.48 (superclass standard-class))
13.49 t)
13.50
13.51+;;; Slot mixin
13.52 (defclass storable-slot-mixin ()
13.53 ((storep :initarg :storep
13.54 :initform t
13.55@@ -101,8 +121,7 @@
13.56 (initialize-class-slots class slots)
13.57 slots))
13.58
13.59-;;;
13.60-
13.61+;;; Identifiable
13.62 (defclass identifiable (id)
13.63 ((id :initform nil :accessor id :storep nil)
13.64 (written :initform nil
14.1--- a/lisp/lib/rt/tests.lisp Sun Apr 14 20:48:25 2024 -0400
14.2+++ b/lisp/lib/rt/tests.lisp Mon Apr 15 22:17:19 2024 -0400
14.3@@ -14,7 +14,7 @@
14.4 (t () 0)))
14.5 (is (= 5 (funcall fx :+)))
14.6 (is (= 7 (funcall fx :+)))
14.7- (is (= 5 (funcall fx :-)))
14.8+ (is (= -1 (funcall fx :-)))
14.9 (is (= 0 (funcall fx))))
14.10 (signals (error t) (test-form (make-instance 'test-result))))
14.11
15.1--- a/lisp/lib/xdb/xdb.lisp Sun Apr 14 20:48:25 2024 -0400
15.2+++ b/lisp/lib/xdb/xdb.lisp Mon Apr 15 22:17:19 2024 -0400
15.3@@ -8,7 +8,7 @@
15.4 (defclass xdb ()
15.5 ((location :initarg :location
15.6 :accessor location
15.7- :initform (error "Location is required"))
15.8+ :initform (required-argument "Location is required"))
15.9 (collections :initarg :collections
15.10 :accessor collections
15.11 :initform (make-hash-table :test 'equal))))
15.12@@ -141,12 +141,6 @@
15.13 :type "log")))
15.14 collection))
15.15
15.16-(defun file-date ()
15.17- "Returns current date as a string."
15.18- (multiple-value-bind (sec min hr day mon yr)
15.19- (get-decoded-time)
15.20- (format nil "~A~A~A_~A~A~A" yr mon day hr min sec)))
15.21-
15.22 (defun append-date (name)
15.23 (format nil "~a-~a" name (file-date)))
15.24
16.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
16.2+++ b/lisp/std/file.lisp Mon Apr 15 22:17:19 2024 -0400
16.3@@ -0,0 +1,368 @@
16.4+;;; std/file.lisp --- Standard File Library
16.5+
16.6+;;
16.7+
16.8+;;; Code:
16.9+(in-package :std)
16.10+
16.11+(declaim (inline octet-vector=/unsafe))
16.12+(defun octet-vector=/unsafe (v1 v2 start1 end1 start2 end2)
16.13+ (declare (optimize (speed 3)
16.14+ (safety 0)
16.15+ (debug 0)
16.16+ (compilation-speed 0))
16.17+ (type octet-vector v1 v2)
16.18+ (type array-index start1 start2)
16.19+ (type array-length end1 end2))
16.20+ (and (= (- end1 start1)
16.21+ (- end2 start2))
16.22+ (loop for i from start1 below end1
16.23+ for j from start2 below end2
16.24+ always (eql (aref v1 i) (aref v2 j)))))
16.25+
16.26+(defun octet-vector= (v1 v2 &key (start1 0) end1
16.27+ (start2 0) end2)
16.28+ "Like `string=' for octet vectors."
16.29+ (declare (octet-vector v1 v2)
16.30+ (array-index start1 start2)
16.31+ ((or array-length null) end1 end2)
16.32+ (optimize speed))
16.33+ (let* ((len1 (length v1))
16.34+ (len2 (length v2))
16.35+ (end1 (or end1 len1))
16.36+ (end2 (or end2 len2)))
16.37+ (assert (<= start1 end1 len1))
16.38+ (assert (<= start2 end2 len2))
16.39+ (octet-vector=/unsafe v1 v2 start1 end1 start2 end2)))
16.40+
16.41+(defun file-size-in-octets (file)
16.42+ (multiple-value-bind (path namestring)
16.43+ (etypecase file
16.44+ (string (values (pathname file)
16.45+ file))
16.46+ (pathname (values file
16.47+ (sb-ext:native-namestring file))))
16.48+ (declare (ignorable path namestring))
16.49+ (sb-posix:stat-size (sb-posix:stat path))))
16.50+
16.51+(define-constant si-prefixes
16.52+ '((-30 "quecto" "q")
16.53+ (-27 "ronto" "r")
16.54+ (-24 "yocto" "y")
16.55+ (-21 "zepto" "z")
16.56+ (-18 "atto" "a")
16.57+ (-15 "femto" "f")
16.58+ (-12 "pico" "p")
16.59+ ( -9 "nano" "n")
16.60+ ( -6 "micro" "μ")
16.61+ ( -3 "milli" "m")
16.62+ ( -2 "centi" "c")
16.63+ ( -1 "deci" "d")
16.64+ ( 0 "" "" )
16.65+ ( 1 "deca" "da")
16.66+ ( 2 "hecto" "h")
16.67+ ( 3 "kilo" "k")
16.68+ ( 6 "mega" "M")
16.69+ ( 9 "giga" "G")
16.70+ ( 12 "tera" "T")
16.71+ ( 15 "peta" "P")
16.72+ ( 18 "exa" "E")
16.73+ ( 21 "zetta" "Z")
16.74+ ( 24 "yotta" "Y")
16.75+ ( 27 "ronna" "R")
16.76+ ( 30 "quetta" "Q"))
16.77+ :test #'equalp
16.78+ :documentation "List as SI prefixes: power of ten, long form, short form.")
16.79+
16.80+(define-constant si-prefixes-base-1000
16.81+ (loop for (pow long short) in si-prefixes
16.82+ unless (and (not (zerop pow))
16.83+ (< (abs pow) 3))
16.84+ collect (list (truncate pow 3) long short))
16.85+ :test #'equalp
16.86+ :documentation "The SI prefixes as powers of 1000, with centi, deci, deca and hecto omitted.")
16.87+
16.88+(define-constant iec-prefixes
16.89+ '(( 0 "" "")
16.90+ (10 "kibi" "Ki")
16.91+ (20 "mebi" "Mi")
16.92+ (30 "gibi" "Gi")
16.93+ (40 "tebi" "Ti")
16.94+ (50 "pebi" "Pi")
16.95+ (60 "exbi" "Ei"))
16.96+ :test #'equalp
16.97+ :documentation "The IEC binary prefixes, as powers of 2.")
16.98+
16.99+(eval-always
16.100+ (defun single (seq)
16.101+ "Is SEQ a sequence of one element?"
16.102+ (= (length seq) 1)))
16.103+
16.104+(defmacro si-prefix-rec (n base prefixes)
16.105+ (cond ((null prefixes) (error "No prefixes!"))
16.106+ ((single prefixes)
16.107+ (destructuring-bind ((power long short)) prefixes
16.108+ `(values ,long ,short ,(expt base power))))
16.109+ (t
16.110+ ;; good enough
16.111+ (let* ((halfway (ceiling (length prefixes) 2))
16.112+ (lo (subseq prefixes 0 halfway))
16.113+ (hi (subseq prefixes halfway))
16.114+ (split (* (expt base (caar hi)))))
16.115+ `(if (< ,n ,split)
16.116+ (si-prefix-rec ,n ,base ,lo)
16.117+ (si-prefix-rec ,n ,base ,hi))))))
16.118+
16.119+(defun si-prefix (n &key (base 1000))
16.120+ "Given a number, return the prefix of the nearest SI unit.
16.121+
16.122+Three values are returned: the long form, the short form, and the
16.123+multiplying factor.
16.124+
16.125+ (si-prefix 1001) => \"kilo\", \"k\", 1000d0
16.126+
16.127+BASE can be 1000, 10, 1024, or 2. 1000 is the default, and prefixes
16.128+start at kilo and milli. Base 10 is mostly the same, except the
16.129+prefixes centi, deci, deca and hecto are also used. Base 1024 uses the
16.130+same prefixes as 1000, but with 1024 as the base, as in vulgar file
16.131+sizes. Base 2 uses the IEC binary prefixes."
16.132+ (if (zerop n) (values "" "" 1d0)
16.133+ (let ((n (abs (coerce n 'double-float))))
16.134+ (ecase base
16.135+ (2 (si-prefix-rec n 2d0 #.iec-prefixes))
16.136+ (10 (si-prefix-rec n 10d0 #.si-prefixes))
16.137+ (1000 (si-prefix-rec n 1000d0 #.si-prefixes-base-1000))
16.138+ (1024 (si-prefix-rec n 1024d0 #.si-prefixes-base-1000))))))
16.139+
16.140+(defun human-size-formatter (size &key (flavor :si)
16.141+ (space (eql flavor :si)))
16.142+ "Auxiliary function for formatting quantities human-readably.
16.143+Returns two values: a format control and a list of arguments.
16.144+
16.145+This can be used to integrate the human-readable printing of
16.146+quantities into larger format control strings using the recursive
16.147+processing format directive (~?):
16.148+
16.149+ (multiple-value-bind (control args)
16.150+ (human-size-formatter size)
16.151+ (format t \"~?\" control args))"
16.152+ (let ((size (coerce size 'double-float))
16.153+ ;; Avoid printing exponent markers.
16.154+ (*read-default-float-format* 'double-float)
16.155+ (base (ecase flavor
16.156+ (:file 1024)
16.157+ (:si 1000)
16.158+ (:iec 2))))
16.159+ (multiple-value-bind (long short factor)
16.160+ (si-prefix size :base base)
16.161+ (declare (ignore long))
16.162+ (let* ((size (/ size factor))
16.163+ (int (round size))
16.164+ (size
16.165+ (if (> (abs (- size int))
16.166+ 0.05d0)
16.167+ size
16.168+ int)))
16.169+ (values (formatter "~:[~d~;~,1f~]~:[~; ~]~a")
16.170+ (list (floatp size) size space short))))))
16.171+
16.172+(defun format-human-size (stream size
16.173+ &key (flavor :si)
16.174+ (space (eql flavor :si)))
16.175+ "Write SIZE to STREAM, in human-readable form.
16.176+
16.177+STREAM is interpreted as by `format'.
16.178+
16.179+If FLAVOR is `:si' (the default) the base is 1000 and SI prefixes are used.
16.180+
16.181+If FLAVOR is `:file', the base is 1024 and SI prefixes are used.
16.182+
16.183+If FLAVOR is `:iec', the base is 1024 bytes and IEC prefixes (Ki, Mi,
16.184+etc.) are used.
16.185+
16.186+If SPACE is non-nil, include a space between the number and the
16.187+prefix. (Defaults to T if FLAVOR is `:si'.)"
16.188+ (if (zerop size)
16.189+ (format stream "0")
16.190+ (multiple-value-bind (formatter args)
16.191+ (human-size-formatter size :flavor flavor :space space)
16.192+ (format stream "~?" formatter args))))
16.193+
16.194+(defun format-file-size-human-readable (stream file-size
16.195+ &key flavor
16.196+ (space (eql flavor :si))
16.197+ (suffix (if (eql flavor :iec) "B" "")))
16.198+ "Write FILE-SIZE, a file size in bytes, to STREAM, in human-readable form.
16.199+
16.200+STREAM is interpreted as by `format'.
16.201+
16.202+If FLAVOR is nil, kilobytes are 1024 bytes and SI prefixes are used.
16.203+
16.204+If FLAVOR is `:si', kilobytes are 1000 bytes and SI prefixes are used.
16.205+
16.206+If FLAVOR is `:iec', kilobytes are 1024 bytes and IEC prefixes (Ki,
16.207+Mi, etc.) are used.
16.208+
16.209+If SPACE is non-nil, include a space between the number and the
16.210+prefix. (Defaults to T if FLAVOR is `:si'.)
16.211+
16.212+SUFFIX is the suffix to use; defaults to B if FLAVOR is `:iec',
16.213+otherwise empty."
16.214+ (check-type file-size (integer 0 *))
16.215+ (if (zerop file-size)
16.216+ (format stream "0")
16.217+ (let ((flavor (if (null flavor) :file flavor)))
16.218+ (multiple-value-bind (formatter args)
16.219+ (human-size-formatter file-size :flavor flavor :space space)
16.220+ (format stream "~?~a" formatter args suffix)))))
16.221+
16.222+(defun file-size-human-readable (file &key flavor space suffix stream)
16.223+ "Format the size of FILE (in octets) using `format-file-size-human-readable'.
16.224+The size of file is found by `trivial-file-size:file-size-in-octets'.
16.225+
16.226+Inspired by the function of the same name in Emacs."
16.227+ (let ((file-size (file-size-in-octets file)))
16.228+ (format-file-size-human-readable
16.229+ stream
16.230+ file-size
16.231+ :flavor flavor
16.232+ :suffix suffix
16.233+ :space space)))
16.234+
16.235+(defmacro with-open-files ((&rest args) &body body)
16.236+ "A simple macro to open one or more files providing the streams for the BODY. The ARGS is a list of `(stream filespec options*)` as supplied to WITH-OPEN-FILE."
16.237+ (case (length args)
16.238+ ((0)
16.239+ `(progn ,@body))
16.240+ ((1)
16.241+ `(with-open-file ,(first args) ,@body))
16.242+ (t `(with-open-file ,(first args)
16.243+ (with-open-files
16.244+ ,(rest args) ,@body)))))
16.245+
16.246+(defmacro with-open-file* ((stream filespec &key direction element-type
16.247+ if-exists if-does-not-exist external-format)
16.248+ &body body)
16.249+ "Just like WITH-OPEN-FILE, but NIL values in the keyword arguments
16.250+mean to use the default value specified for OPEN."
16.251+ (once-only (direction element-type if-exists if-does-not-exist external-format)
16.252+ `(with-open-stream
16.253+ (,stream (apply #'open ,filespec
16.254+ (append
16.255+ (when ,direction
16.256+ (list :direction ,direction))
16.257+ (list :element-type (or ,element-type
16.258+ +default-element-type+))
16.259+ (when ,if-exists
16.260+ (list :if-exists ,if-exists))
16.261+ (when ,if-does-not-exist
16.262+ (list :if-does-not-exist ,if-does-not-exist))
16.263+ (when ,external-format
16.264+ (list :external-format ,external-format)))))
16.265+ ,@body)))
16.266+
16.267+(defmacro with-input-from-file ((stream-name file-name &rest args
16.268+ &key (direction nil direction-p)
16.269+ &allow-other-keys)
16.270+ &body body)
16.271+ "Evaluate BODY with STREAM-NAME to an input stream on the file
16.272+FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
16.273+which is only sent to WITH-OPEN-FILE when it's not NIL."
16.274+ (declare (ignore direction))
16.275+ (when direction-p
16.276+ (error "Can't specify :DIRECTION for WITH-INPUT-FROM-FILE."))
16.277+ `(with-open-file* (,stream-name ,file-name :direction :input ,@args)
16.278+ ,@body))
16.279+
16.280+(defmacro with-output-to-file ((stream-name file-name &rest args
16.281+ &key (direction nil direction-p)
16.282+ &allow-other-keys)
16.283+ &body body)
16.284+ "Evaluate BODY with STREAM-NAME to an output stream on the file
16.285+FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
16.286+which is only sent to WITH-OPEN-FILE when it's not NIL."
16.287+ (declare (ignore direction))
16.288+ (when direction-p
16.289+ (error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE."))
16.290+ `(with-open-file* (,stream-name ,file-name :direction :output ,@args)
16.291+ ,@body))
16.292+
16.293+(defun write-stream-into-file (stream pathname &key (if-exists :error) if-does-not-exist)
16.294+ "Read STREAM and write the contents into PATHNAME.
16.295+
16.296+STREAM will be closed afterwards, so wrap it with
16.297+`make-concatenated-stream' if you want it left open."
16.298+ (check-type pathname pathname)
16.299+ (with-open-stream (in stream)
16.300+ (with-output-to-file (out pathname
16.301+ :element-type (stream-element-type in)
16.302+ :if-exists if-exists
16.303+ :if-does-not-exist if-does-not-exist)
16.304+ (copy-stream in out)))
16.305+ pathname)
16.306+
16.307+(defun write-file-into-stream (pathname output &key (if-does-not-exist :error)
16.308+ (external-format :default))
16.309+ "Write the contents of FILE into STREAM."
16.310+ (check-type pathname pathname)
16.311+ (with-input-from-file (input pathname
16.312+ :element-type (stream-element-type output)
16.313+ :if-does-not-exist if-does-not-exist
16.314+ :external-format external-format)
16.315+ (copy-stream input output)))
16.316+
16.317+(defun file= (file1 file2 &key (buffer-size 4096))
16.318+ "Compare FILE1 and FILE2 octet by octet, \(possibly) using buffers
16.319+of BUFFER-SIZE."
16.320+ (declare (ignorable buffer-size))
16.321+ (let ((file1 (truename file1))
16.322+ (file2 (truename file2)))
16.323+ (or (equal file1 file2)
16.324+ (and (= (file-size-in-octets file1)
16.325+ (file-size-in-octets file2))
16.326+ #+ccl (file=/mmap file1 file2)
16.327+ #-ccl (file=/loop file1 file2 :buffer-size buffer-size)))))
16.328+
16.329+(defun file=/loop (file1 file2 &key (buffer-size 4096))
16.330+ "Compare two files by looping over their contents using a buffer."
16.331+ (declare
16.332+ (type pathname file1 file2)
16.333+ (type array-length buffer-size)
16.334+ (optimize (safety 1) (debug 0) (compilation-speed 0)))
16.335+ (flet ((make-buffer ()
16.336+ (make-array buffer-size
16.337+ :element-type 'octet
16.338+ :initial-element 0)))
16.339+ (declare (inline make-buffer))
16.340+ (with-open-files ((file1 file1 :element-type 'octet :direction :input)
16.341+ (file2 file2 :element-type 'octet :direction :input))
16.342+ (and (= (file-length file1)
16.343+ (file-length file2))
16.344+ (locally (declare (optimize speed))
16.345+ (loop with buffer1 = (make-buffer)
16.346+ with buffer2 = (make-buffer)
16.347+ for end1 = (read-sequence buffer1 file1)
16.348+ for end2 = (read-sequence buffer2 file2)
16.349+ until (or (zerop end1) (zerop end2))
16.350+ always (and (= end1 end2)
16.351+ (octet-vector= buffer1 buffer2
16.352+ :end1 end1
16.353+ :end2 end2))))))))
16.354+
16.355+(defun file-size (file &key (element-type '(unsigned-byte 8)))
16.356+ "The size of FILE, in units of ELEMENT-TYPE (defaults to bytes).
16.357+
16.358+The size is computed by opening the file and getting the length of the
16.359+resulting stream.
16.360+
16.361+If all you want is to read the file's size in octets from its
16.362+metadata, consider `trivial-file-size:file-size-in-octets' instead."
16.363+ (check-type file (or string pathname))
16.364+ (with-input-from-file (in file :element-type element-type)
16.365+ (file-length in)))
16.366+
16.367+(defun file-date ()
16.368+ "Returns current date as a string suitable as the name of a timestamped-file."
16.369+ (multiple-value-bind (sec min hr day mon yr)
16.370+ (get-decoded-time)
16.371+ (format nil "~4d~2d~2d_~2d~2d~2d" yr mon day hr min sec)))
17.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
17.2+++ b/lisp/std/path.lisp Mon Apr 15 22:17:19 2024 -0400
17.3@@ -0,0 +1,36 @@
17.4+;;; std/path.lisp --- Standard Path Library
17.5+
17.6+;;
17.7+
17.8+;;; Code:
17.9+(in-package :std)
17.10+
17.11+(deftype wild-pathname ()
17.12+ "A pathname with wild components."
17.13+ '(and pathname (satisfies wild-pathname-p)))
17.14+
17.15+(deftype non-wild-pathname ()
17.16+ "A pathname without wild components."
17.17+ '(or directory-pathname
17.18+ (and pathname (not (satisfies wild-pathname-p)))))
17.19+
17.20+(deftype absolute-pathname ()
17.21+ '(and pathname (satisfies uiop:absolute-pathname-p)))
17.22+
17.23+(deftype relative-pathname ()
17.24+ '(and pathname (satisfies uiop:relative-pathname-p)))
17.25+
17.26+(deftype directory-pathname ()
17.27+ '(and pathname (satisfies uiop:directory-pathname-p)))
17.28+
17.29+(deftype absolute-directory-pathname ()
17.30+ '(and absolute-pathname directory-pathname))
17.31+
17.32+(deftype file-pathname ()
17.33+ '(and pathname (satisfies uiop:file-pathname-p)))
17.34+
17.35+;; logical-pathname is defined in CL.
17.36+
17.37+(defconstant +pathsep+
17.38+ #+windows #\; #+unix #\:
17.39+ "Path separator for this OS.")
18.1--- a/lisp/std/pkg.lisp Sun Apr 14 20:48:25 2024 -0400
18.2+++ b/lisp/std/pkg.lisp Mon Apr 15 22:17:19 2024 -0400
18.3@@ -48,12 +48,15 @@
18.4 :encode-float64
18.5 :decode-float64
18.6 ;; stream
18.7+ :copy-stream
18.8+ ;; path
18.9 #:wild-pathname
18.10 #:non-wild-pathname
18.11 #:absolute-pathname
18.12 #:relative-pathname
18.13 #:directory-pathname
18.14 #:absolute-directory-pathname
18.15+ ;; file
18.16 #:file-pathname
18.17 #:with-open-files
18.18 #:write-stream-into-file
18.19@@ -63,6 +66,7 @@
18.20 :file-size-in-octets
18.21 :+pathsep+
18.22 :octet-vector=
18.23+ :file-date
18.24 ;; string
18.25 :*omit-nulls*
18.26 :*whitespaces*
18.27@@ -106,6 +110,7 @@
18.28 :thread-count :dump-thread
18.29 :make-oracle :make-supervisor :oracle
18.30 :push-job :push-task :push-worker :push-result
18.31+ :pop-job :pop-task :pop-worker :pop-result
18.32 :start-task-pool :pause-task-pool :shutdown-task-pool
18.33 :push-stage :designate-oracle :make-task-pool
18.34 :task :job :task-pool :stage :task-pool-p
19.1--- a/lisp/std/std.asd Sun Apr 14 20:48:25 2024 -0400
19.2+++ b/lisp/std/std.asd Mon Apr 15 22:17:19 2024 -0400
19.3@@ -26,7 +26,9 @@
19.4 (:file "pan")
19.5 (:file "fu")
19.6 (:file "types")
19.7+ (:file "path")
19.8 (:file "stream")
19.9+ (:file "file")
19.10 (:file "thread")
19.11 (:file "defpkg")
19.12 (:file "alien"))
20.1--- a/lisp/std/stream.lisp Sun Apr 14 20:48:25 2024 -0400
20.2+++ b/lisp/std/stream.lisp Mon Apr 15 22:17:19 2024 -0400
20.3@@ -4,315 +4,6 @@
20.4
20.5 ;;; Code:
20.6 (in-package :std)
20.7-(declaim (inline octet-vector=/unsafe))
20.8-(defun octet-vector=/unsafe (v1 v2 start1 end1 start2 end2)
20.9- (declare (optimize (speed 3)
20.10- (safety 0)
20.11- (debug 0)
20.12- (compilation-speed 0))
20.13- (type octet-vector v1 v2)
20.14- (type array-index start1 start2)
20.15- (type array-length end1 end2))
20.16- (and (= (- end1 start1)
20.17- (- end2 start2))
20.18- (loop for i from start1 below end1
20.19- for j from start2 below end2
20.20- always (eql (aref v1 i) (aref v2 j)))))
20.21-
20.22-(defun octet-vector= (v1 v2 &key (start1 0) end1
20.23- (start2 0) end2)
20.24- "Like `string=' for octet vectors."
20.25- (declare (octet-vector v1 v2)
20.26- (array-index start1 start2)
20.27- ((or array-length null) end1 end2)
20.28- (optimize speed))
20.29- (let* ((len1 (length v1))
20.30- (len2 (length v2))
20.31- (end1 (or end1 len1))
20.32- (end2 (or end2 len2)))
20.33- (assert (<= start1 end1 len1))
20.34- (assert (<= start2 end2 len2))
20.35- (octet-vector=/unsafe v1 v2 start1 end1 start2 end2)))
20.36-
20.37-(defun file-size-in-octets (file)
20.38- (multiple-value-bind (path namestring)
20.39- (etypecase file
20.40- (string (values (pathname file)
20.41- file))
20.42- (pathname (values file
20.43- (sb-ext:native-namestring file))))
20.44- (declare (ignorable path namestring))
20.45- (sb-posix:stat-size (sb-posix:stat path))))
20.46-
20.47-(define-constant si-prefixes
20.48- '((-30 "quecto" "q")
20.49- (-27 "ronto" "r")
20.50- (-24 "yocto" "y")
20.51- (-21 "zepto" "z")
20.52- (-18 "atto" "a")
20.53- (-15 "femto" "f")
20.54- (-12 "pico" "p")
20.55- ( -9 "nano" "n")
20.56- ( -6 "micro" "μ")
20.57- ( -3 "milli" "m")
20.58- ( -2 "centi" "c")
20.59- ( -1 "deci" "d")
20.60- ( 0 "" "" )
20.61- ( 1 "deca" "da")
20.62- ( 2 "hecto" "h")
20.63- ( 3 "kilo" "k")
20.64- ( 6 "mega" "M")
20.65- ( 9 "giga" "G")
20.66- ( 12 "tera" "T")
20.67- ( 15 "peta" "P")
20.68- ( 18 "exa" "E")
20.69- ( 21 "zetta" "Z")
20.70- ( 24 "yotta" "Y")
20.71- ( 27 "ronna" "R")
20.72- ( 30 "quetta" "Q"))
20.73- :test #'equalp
20.74- :documentation "List as SI prefixes: power of ten, long form, short form.")
20.75-
20.76-(define-constant si-prefixes-base-1000
20.77- (loop for (pow long short) in si-prefixes
20.78- unless (and (not (zerop pow))
20.79- (< (abs pow) 3))
20.80- collect (list (truncate pow 3) long short))
20.81- :test #'equalp
20.82- :documentation "The SI prefixes as powers of 1000, with centi, deci, deca and hecto omitted.")
20.83-
20.84-(define-constant iec-prefixes
20.85- '(( 0 "" "")
20.86- (10 "kibi" "Ki")
20.87- (20 "mebi" "Mi")
20.88- (30 "gibi" "Gi")
20.89- (40 "tebi" "Ti")
20.90- (50 "pebi" "Pi")
20.91- (60 "exbi" "Ei"))
20.92- :test #'equalp
20.93- :documentation "The IEC binary prefixes, as powers of 2.")
20.94-
20.95-(eval-always
20.96- (defun single (seq)
20.97- "Is SEQ a sequence of one element?"
20.98- (= (length seq) 1)))
20.99-
20.100-(defmacro si-prefix-rec (n base prefixes)
20.101- (cond ((null prefixes) (error "No prefixes!"))
20.102- ((single prefixes)
20.103- (destructuring-bind ((power long short)) prefixes
20.104- `(values ,long ,short ,(expt base power))))
20.105- (t
20.106- ;; good enough
20.107- (let* ((halfway (ceiling (length prefixes) 2))
20.108- (lo (subseq prefixes 0 halfway))
20.109- (hi (subseq prefixes halfway))
20.110- (split (* (expt base (caar hi)))))
20.111- `(if (< ,n ,split)
20.112- (si-prefix-rec ,n ,base ,lo)
20.113- (si-prefix-rec ,n ,base ,hi))))))
20.114-
20.115-(defun si-prefix (n &key (base 1000))
20.116- "Given a number, return the prefix of the nearest SI unit.
20.117-
20.118-Three values are returned: the long form, the short form, and the
20.119-multiplying factor.
20.120-
20.121- (si-prefix 1001) => \"kilo\", \"k\", 1000d0
20.122-
20.123-BASE can be 1000, 10, 1024, or 2. 1000 is the default, and prefixes
20.124-start at kilo and milli. Base 10 is mostly the same, except the
20.125-prefixes centi, deci, deca and hecto are also used. Base 1024 uses the
20.126-same prefixes as 1000, but with 1024 as the base, as in vulgar file
20.127-sizes. Base 2 uses the IEC binary prefixes."
20.128- (if (zerop n) (values "" "" 1d0)
20.129- (let ((n (abs (coerce n 'double-float))))
20.130- (ecase base
20.131- (2 (si-prefix-rec n 2d0 #.iec-prefixes))
20.132- (10 (si-prefix-rec n 10d0 #.si-prefixes))
20.133- (1000 (si-prefix-rec n 1000d0 #.si-prefixes-base-1000))
20.134- (1024 (si-prefix-rec n 1024d0 #.si-prefixes-base-1000))))))
20.135-
20.136-(defun human-size-formatter (size &key (flavor :si)
20.137- (space (eql flavor :si)))
20.138- "Auxiliary function for formatting quantities human-readably.
20.139-Returns two values: a format control and a list of arguments.
20.140-
20.141-This can be used to integrate the human-readable printing of
20.142-quantities into larger format control strings using the recursive
20.143-processing format directive (~?):
20.144-
20.145- (multiple-value-bind (control args)
20.146- (human-size-formatter size)
20.147- (format t \"~?\" control args))"
20.148- (let ((size (coerce size 'double-float))
20.149- ;; Avoid printing exponent markers.
20.150- (*read-default-float-format* 'double-float)
20.151- (base (ecase flavor
20.152- (:file 1024)
20.153- (:si 1000)
20.154- (:iec 2))))
20.155- (multiple-value-bind (long short factor)
20.156- (si-prefix size :base base)
20.157- (declare (ignore long))
20.158- (let* ((size (/ size factor))
20.159- (int (round size))
20.160- (size
20.161- (if (> (abs (- size int))
20.162- 0.05d0)
20.163- size
20.164- int)))
20.165- (values (formatter "~:[~d~;~,1f~]~:[~; ~]~a")
20.166- (list (floatp size) size space short))))))
20.167-
20.168-(defun format-human-size (stream size
20.169- &key (flavor :si)
20.170- (space (eql flavor :si)))
20.171- "Write SIZE to STREAM, in human-readable form.
20.172-
20.173-STREAM is interpreted as by `format'.
20.174-
20.175-If FLAVOR is `:si' (the default) the base is 1000 and SI prefixes are used.
20.176-
20.177-If FLAVOR is `:file', the base is 1024 and SI prefixes are used.
20.178-
20.179-If FLAVOR is `:iec', the base is 1024 bytes and IEC prefixes (Ki, Mi,
20.180-etc.) are used.
20.181-
20.182-If SPACE is non-nil, include a space between the number and the
20.183-prefix. (Defaults to T if FLAVOR is `:si'.)"
20.184- (if (zerop size)
20.185- (format stream "0")
20.186- (multiple-value-bind (formatter args)
20.187- (human-size-formatter size :flavor flavor :space space)
20.188- (format stream "~?" formatter args))))
20.189-
20.190-(defun format-file-size-human-readable (stream file-size
20.191- &key flavor
20.192- (space (eql flavor :si))
20.193- (suffix (if (eql flavor :iec) "B" "")))
20.194- "Write FILE-SIZE, a file size in bytes, to STREAM, in human-readable form.
20.195-
20.196-STREAM is interpreted as by `format'.
20.197-
20.198-If FLAVOR is nil, kilobytes are 1024 bytes and SI prefixes are used.
20.199-
20.200-If FLAVOR is `:si', kilobytes are 1000 bytes and SI prefixes are used.
20.201-
20.202-If FLAVOR is `:iec', kilobytes are 1024 bytes and IEC prefixes (Ki,
20.203-Mi, etc.) are used.
20.204-
20.205-If SPACE is non-nil, include a space between the number and the
20.206-prefix. (Defaults to T if FLAVOR is `:si'.)
20.207-
20.208-SUFFIX is the suffix to use; defaults to B if FLAVOR is `:iec',
20.209-otherwise empty."
20.210- (check-type file-size (integer 0 *))
20.211- (if (zerop file-size)
20.212- (format stream "0")
20.213- (let ((flavor (if (null flavor) :file flavor)))
20.214- (multiple-value-bind (formatter args)
20.215- (human-size-formatter file-size :flavor flavor :space space)
20.216- (format stream "~?~a" formatter args suffix)))))
20.217-
20.218-(defun file-size-human-readable (file &key flavor space suffix stream)
20.219- "Format the size of FILE (in octets) using `format-file-size-human-readable'.
20.220-The size of file is found by `trivial-file-size:file-size-in-octets'.
20.221-
20.222-Inspired by the function of the same name in Emacs."
20.223- (let ((file-size (file-size-in-octets file)))
20.224- (format-file-size-human-readable
20.225- stream
20.226- file-size
20.227- :flavor flavor
20.228- :suffix suffix
20.229- :space space)))
20.230-
20.231-(deftype wild-pathname ()
20.232- "A pathname with wild components."
20.233- '(and pathname (satisfies wild-pathname-p)))
20.234-
20.235-(deftype non-wild-pathname ()
20.236- "A pathname without wild components."
20.237- '(or directory-pathname
20.238- (and pathname (not (satisfies wild-pathname-p)))))
20.239-
20.240-(deftype absolute-pathname ()
20.241- '(and pathname (satisfies uiop:absolute-pathname-p)))
20.242-
20.243-(deftype relative-pathname ()
20.244- '(and pathname (satisfies uiop:relative-pathname-p)))
20.245-
20.246-(deftype directory-pathname ()
20.247- '(and pathname (satisfies uiop:directory-pathname-p)))
20.248-
20.249-(deftype absolute-directory-pathname ()
20.250- '(and absolute-pathname directory-pathname))
20.251-
20.252-(deftype file-pathname ()
20.253- '(and pathname (satisfies uiop:file-pathname-p)))
20.254-
20.255-;;; logical-pathname is defined in CL.
20.256-
20.257-(defconstant +default-element-type+ 'character)
20.258-
20.259-(defmacro with-open-files ((&rest args) &body body)
20.260- "A simple macro to open one or more files providing the streams for the BODY. The ARGS is a list of `(stream filespec options*)` as supplied to WITH-OPEN-FILE."
20.261- (case (length args)
20.262- ((0)
20.263- `(progn ,@body))
20.264- ((1)
20.265- `(with-open-file ,(first args) ,@body))
20.266- (t `(with-open-file ,(first args)
20.267- (with-open-files
20.268- ,(rest args) ,@body)))))
20.269-
20.270-(defmacro with-open-file* ((stream filespec &key direction element-type
20.271- if-exists if-does-not-exist external-format)
20.272- &body body)
20.273- "Just like WITH-OPEN-FILE, but NIL values in the keyword arguments
20.274-mean to use the default value specified for OPEN."
20.275- (once-only (direction element-type if-exists if-does-not-exist external-format)
20.276- `(with-open-stream
20.277- (,stream (apply #'open ,filespec
20.278- (append
20.279- (when ,direction
20.280- (list :direction ,direction))
20.281- (list :element-type (or ,element-type
20.282- +default-element-type+))
20.283- (when ,if-exists
20.284- (list :if-exists ,if-exists))
20.285- (when ,if-does-not-exist
20.286- (list :if-does-not-exist ,if-does-not-exist))
20.287- (when ,external-format
20.288- (list :external-format ,external-format)))))
20.289- ,@body)))
20.290-
20.291-(defmacro with-input-from-file ((stream-name file-name &rest args
20.292- &key (direction nil direction-p)
20.293- &allow-other-keys)
20.294- &body body)
20.295- "Evaluate BODY with STREAM-NAME to an input stream on the file
20.296-FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
20.297-which is only sent to WITH-OPEN-FILE when it's not NIL."
20.298- (declare (ignore direction))
20.299- (when direction-p
20.300- (error "Can't specify :DIRECTION for WITH-INPUT-FROM-FILE."))
20.301- `(with-open-file* (,stream-name ,file-name :direction :input ,@args)
20.302- ,@body))
20.303-
20.304-(defmacro with-output-to-file ((stream-name file-name &rest args
20.305- &key (direction nil direction-p)
20.306- &allow-other-keys)
20.307- &body body)
20.308- "Evaluate BODY with STREAM-NAME to an output stream on the file
20.309-FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
20.310-which is only sent to WITH-OPEN-FILE when it's not NIL."
20.311- (declare (ignore direction))
20.312- (when direction-p
20.313- (error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE."))
20.314- `(with-open-file* (,stream-name ,file-name :direction :output ,@args)
20.315- ,@body))
20.316
20.317 (defun copy-stream (input output &key (element-type (stream-element-type input))
20.318 (buffer-size 4096)
20.319@@ -357,81 +48,3 @@
20.320 (when finish-output
20.321 (finish-output output))
20.322 output-position))
20.323-
20.324-(defun write-stream-into-file (stream pathname &key (if-exists :error) if-does-not-exist)
20.325- "Read STREAM and write the contents into PATHNAME.
20.326-
20.327-STREAM will be closed afterwards, so wrap it with
20.328-`make-concatenated-stream' if you want it left open."
20.329- (check-type pathname pathname)
20.330- (with-open-stream (in stream)
20.331- (with-output-to-file (out pathname
20.332- :element-type (stream-element-type in)
20.333- :if-exists if-exists
20.334- :if-does-not-exist if-does-not-exist)
20.335- (copy-stream in out)))
20.336- pathname)
20.337-
20.338-(defun write-file-into-stream (pathname output &key (if-does-not-exist :error)
20.339- (external-format :default))
20.340- "Write the contents of FILE into STREAM."
20.341- (check-type pathname pathname)
20.342- (with-input-from-file (input pathname
20.343- :element-type (stream-element-type output)
20.344- :if-does-not-exist if-does-not-exist
20.345- :external-format external-format)
20.346- (copy-stream input output)))
20.347-
20.348-(defun file= (file1 file2 &key (buffer-size 4096))
20.349- "Compare FILE1 and FILE2 octet by octet, \(possibly) using buffers
20.350-of BUFFER-SIZE."
20.351- (declare (ignorable buffer-size))
20.352- (let ((file1 (truename file1))
20.353- (file2 (truename file2)))
20.354- (or (equal file1 file2)
20.355- (and (= (file-size-in-octets file1)
20.356- (file-size-in-octets file2))
20.357- #+ccl (file=/mmap file1 file2)
20.358- #-ccl (file=/loop file1 file2 :buffer-size buffer-size)))))
20.359-
20.360-(defun file=/loop (file1 file2 &key (buffer-size 4096))
20.361- "Compare two files by looping over their contents using a buffer."
20.362- (declare
20.363- (type pathname file1 file2)
20.364- (type array-length buffer-size)
20.365- (optimize (safety 1) (debug 0) (compilation-speed 0)))
20.366- (flet ((make-buffer ()
20.367- (make-array buffer-size
20.368- :element-type 'octet
20.369- :initial-element 0)))
20.370- (declare (inline make-buffer))
20.371- (with-open-files ((file1 file1 :element-type 'octet :direction :input)
20.372- (file2 file2 :element-type 'octet :direction :input))
20.373- (and (= (file-length file1)
20.374- (file-length file2))
20.375- (locally (declare (optimize speed))
20.376- (loop with buffer1 = (make-buffer)
20.377- with buffer2 = (make-buffer)
20.378- for end1 = (read-sequence buffer1 file1)
20.379- for end2 = (read-sequence buffer2 file2)
20.380- until (or (zerop end1) (zerop end2))
20.381- always (and (= end1 end2)
20.382- (octet-vector= buffer1 buffer2
20.383- :end1 end1
20.384- :end2 end2))))))))
20.385-
20.386-(defun file-size (file &key (element-type '(unsigned-byte 8)))
20.387- "The size of FILE, in units of ELEMENT-TYPE (defaults to bytes).
20.388-
20.389-The size is computed by opening the file and getting the length of the
20.390-resulting stream.
20.391-
20.392-If all you want is to read the file's size in octets from its
20.393-metadata, consider `trivial-file-size:file-size-in-octets' instead."
20.394- (check-type file (or string pathname))
20.395- (with-input-from-file (in file :element-type element-type)
20.396- (file-length in)))
20.397-
20.398-(defconstant +pathsep+
20.399- (if (uiop:os-windows-p) #\; #\:)
20.400- "Path separator for this OS.")
21.1--- a/lisp/std/thread.lisp Sun Apr 14 20:48:25 2024 -0400
21.2+++ b/lisp/std/thread.lisp Mon Apr 15 22:17:19 2024 -0400
21.3@@ -166,16 +166,24 @@
21.4 (defgeneric push-result (task pool))
21.5 (defgeneric push-worker (thread pool))
21.6 (defgeneric push-stage (stage pool))
21.7+(defgeneric pop-job (pool))
21.8+(defgeneric pop-task (pool))
21.9+(defgeneric pop-result (pool))
21.10+(defgeneric pop-worker (pool))
21.11+(defgeneric pop-stage (pool))
21.12 (defgeneric start-task-pool (pool))
21.13 (defgeneric pause-task-pool (pool))
21.14 (defgeneric stop-task-pool (pool))
21.15-(defgeneric make-task (&rest args &key))
21.16+(defgeneric make-task (&rest args))
21.17+(defgeneric run-job (self job))
21.18+(defgeneric run-stage (self stage))
21.19+(defgeneric run-task (self task))
21.20
21.21 (defstruct task-pool
21.22 (oracle nil :type (or null oracle))
21.23 (jobs (sb-concurrency:make-queue :name "jobs"))
21.24- (stages #() :type (vector stage))
21.25- (workers (make-array 0 :element-type 'thread :adjustable t :fill-pointer 0) :type (vector thread))
21.26+ (stages (make-array 0 :element-type 'stage :fill-pointer 0) :type (array stage *))
21.27+ (workers (make-array 0 :element-type 'thread :fill-pointer 0) :type (array thread *))
21.28 (results (sb-concurrency:make-queue :name "results")))
21.29
21.30 (defmethod designate-oracle ((self task-pool) (guest oracle))
21.31@@ -192,20 +200,49 @@
21.32 (vector-push worker (task-pool-workers pool)))
21.33
21.34 (defclass task ()
21.35- ((object :initarg :object :accessor task-object)))
21.36+ ((state :initarg :state :accessor task-state)
21.37+ (object :initarg :object :accessor task-object))
21.38+ (:documentation "This object represents a single unit of work to be done by some
21.39+worker. Tasks are typically generated by an oracle, but workers may
21.40+also be granted the ability to create and distribute their own
21.41+tasks. Once a task is assigned, the 'owner', i.e. the worker that is
21.42+assigned this task, may modify the object and state. When the work
21.43+associated with a task is complete, the owner is responsible for
21.44+indicating in the state slot the result of the computation."))
21.45+
21.46+(defmethod make-task (&rest args)
21.47+ (make-instance 'task :object args))
21.48+
21.49+(defmethod print-object ((self task) stream)
21.50+ (print-unreadable-object (self stream :type t)
21.51+ (format stream "~A" (task-object self))))
21.52
21.53 (defmethod push-result ((task task) (pool task-pool))
21.54 (sb-concurrency:enqueue task (task-pool-results pool)))
21.55
21.56-(defstruct job
21.57+(defstruct (job (:constructor %make-job (tasks)))
21.58+ "A collection of tasks to be performed by worker threads."
21.59 (tasks (make-array 0 :element-type 'task :fill-pointer 0 :adjustable t)
21.60- :type (vector task)))
21.61+ :type (array task *)))
21.62+
21.63+(defmethod make-job ((self task))
21.64+ (%make-job (vector self)))
21.65+
21.66+(defmethod make-job ((self vector))
21.67+ (%make-job self))
21.68+
21.69+(defmethod make-job ((self t))
21.70+ (%make-job (vector self)))
21.71+
21.72+(defmethod print-object ((self job) stream)
21.73+ (print-unreadable-object (self stream :type t)
21.74+ (format stream "~A" (job-tasks self))))
21.75
21.76 (defmethod push-task ((task task) (job job))
21.77 (vector-push task (job-tasks job)))
21.78
21.79 (defmethod push-task ((task task) (pool task-pool))
21.80- (push-job (make-job :tasks (vector task)) pool))
21.81+ (push-job (make-job task) pool))
21.82
21.83 (defmethod push-job ((job job) (pool task-pool))
21.84 (sb-concurrency:enqueue job (task-pool-jobs pool)))
21.85@@ -213,8 +250,12 @@
21.86 (defclass stage ()
21.87 ((jobs :initform (make-array 0 :element-type 'task :fill-pointer 0 :adjustable t)
21.88 :initarg :jobs
21.89- :accessor :jobs
21.90+ :accessor jobs
21.91 :type (vector job))))
21.92
21.93+(defmethod print-object ((self stage) stream)
21.94+ (print-unreadable-object (self stream :type t)
21.95+ (format stream "~A" (jobs self))))
21.96+
21.97 (defmethod push-stage ((stage stage) (pool task-pool))
21.98- (vector-push-extend stage (task-pool-stages pool)))
21.99+ (vector-push stage (task-pool-stages pool)))
22.1--- a/lisp/std/types.lisp Sun Apr 14 20:48:25 2024 -0400
22.2+++ b/lisp/std/types.lisp Mon Apr 15 22:17:19 2024 -0400
22.3@@ -4,6 +4,9 @@
22.4
22.5 ;;; Code:
22.6 (in-package :std)
22.7+
22.8+(defconstant +default-element-type+ 'character)
22.9+
22.10 (deftype array-index (&optional (length (1- array-dimension-limit)))
22.11 "Type designator for an index into array of LENGTH: an integer between
22.12 0 (inclusive) and LENGTH (exclusive). LENGTH defaults to one less than
