396 lines
16 KiB
Common Lisp
396 lines
16 KiB
Common Lisp
(defpackage clash/format
|
|
(:documentation "Formatters for trashinfos and trash directories.")
|
|
(:import-from #:cl-xdg-trash/mountpoints
|
|
#:file-or-dir-namestring)
|
|
(:import-from #:cl-xdg-trash/directorysizes
|
|
#:trashed-file-size)
|
|
(:import-from #:cl-xdg-trash/trashinfo
|
|
#:trashinfo-trash-directory
|
|
#:trashinfo-name
|
|
#:trashinfo-deletion-date
|
|
#:trashinfo-original-path
|
|
#:trashinfo-info-file
|
|
#:trashinfo-trashed-file)
|
|
(:use #:cl)
|
|
(:export #:trashinfo-size
|
|
#:format-size
|
|
#:parse-format-string
|
|
#:option-format-string
|
|
#:option-format-string-directives
|
|
#:format-object
|
|
#:format-list
|
|
#:print-format-info
|
|
#:*trashinfo-formatters*
|
|
#:*directory-formatters*
|
|
#:print-clash-format-info
|
|
#:*missing-file-formatters*
|
|
#:*format-switch-base-two-base-ten*))
|
|
|
|
(in-package :clash/format)
|
|
|
|
(defvar *trashinfo-size-cache* (make-hash-table :test #'eq)
|
|
"Cache for trashinfo sizes.")
|
|
|
|
(defun trashinfo-size (trashinfo)
|
|
"Return the size of TRASHINFO and cache it."
|
|
(let ((res (gethash trashinfo *trashinfo-size-cache* :none)))
|
|
(if (eq res :none)
|
|
(setf (gethash trashinfo *trashinfo-size-cache*)
|
|
(trashed-file-size (trashinfo-trash-directory trashinfo)
|
|
(trashinfo-name trashinfo)))
|
|
res)))
|
|
|
|
(defun format-size (count &optional base-two (places 2))
|
|
"Pretty print COUNT, which is a number of bytes. This will append metric
|
|
suffixes as necessary. If BASE-TWO is non-nil, use MiB, GiB, etc. suffixes
|
|
instead."
|
|
(if (not count)
|
|
"N/A" ;; if finding the size failed
|
|
(let* ((base (if base-two 1024 1000))
|
|
(power (min 10 (floor (if (zerop count) 0 (log count base))))))
|
|
(if (zerop power)
|
|
(format nil "~DB" count)
|
|
(format nil "~,VF~[~:[k~;K~]~:*~;M~;G~;T~;P~;E~;Z~;Y~;R~;Q~]~@[i~]B"
|
|
places (/ count (expt base power))
|
|
(1- power) base-two)))))
|
|
|
|
(defclass format-code ()
|
|
((name :reader format-code-name
|
|
:type character
|
|
:initarg :name
|
|
:documentation "The character used to invoke this formatter.")
|
|
(action :reader format-code-action
|
|
:type (function (stream t) t)
|
|
:initarg :action
|
|
:documentation "The function to call to use this formatter.")
|
|
(padder :reader format-code-padder
|
|
:type (or null
|
|
(function (stream (member nil :left :right) string t) t))
|
|
:initarg :padder
|
|
:initform nil
|
|
:documentation
|
|
"An optional function to pad the result of the action.")
|
|
(doc :reader format-code-doc
|
|
:type (or null string)
|
|
:initarg :doc
|
|
:initform nil
|
|
:documentation "The documentation for this format code."))
|
|
(:documentation "A single format escape sequence."))
|
|
|
|
(defmethod print-object ((obj format-code) stream)
|
|
(print-unreadable-object (obj stream :type t :identity t)
|
|
(with-slots (name padder) obj
|
|
(format stream "%~A~@[ (supports padding)~]" name padder))))
|
|
|
|
(defun make-format-code (&rest args)
|
|
(apply #'make-instance 'format-code args))
|
|
|
|
(defun parse-format-string (format-string directives)
|
|
"Parse FORMAT-STRING into a list of string and functions."
|
|
(let ((start 0)
|
|
out end)
|
|
(labels ((ensure-next-char (i thing)
|
|
(unless (< i (1- (length format-string)))
|
|
(error "Unterminated ~A at char ~A: ~S" thing i format-string)))
|
|
(unknown (i thing)
|
|
(error "Unknown ~A at char ~A: ~S" thing i format-string))
|
|
(push-thing (thing)
|
|
(if (null out)
|
|
(setq out (list thing)
|
|
end out)
|
|
(setf (cdr end) (list thing)
|
|
end (cdr end))))
|
|
(push-string (str)
|
|
(unless (zerop (length str))
|
|
(if (stringp (car end))
|
|
(setf (car end) (format nil "~A~A" (car end) str))
|
|
(push-thing str)))))
|
|
(do ((i 0 (1+ i)))
|
|
((>= i (length format-string)))
|
|
(case (aref format-string i)
|
|
(#\%
|
|
(ensure-next-char i "substitution")
|
|
(push-string (subseq format-string start i))
|
|
(let* ((start-i i)
|
|
(next-c (aref format-string (1+ i)))
|
|
(pad-type (case next-c (#\< :left) (#\> :right) (t nil))))
|
|
(when pad-type
|
|
(ensure-next-char (1+ i) "substitution")
|
|
(setq next-c (aref format-string (+ i 2)))
|
|
(incf i)
|
|
(incf start))
|
|
(setq start (+ i 2)
|
|
i (1+ i))
|
|
(case next-c
|
|
(#\% (push-string "%"))
|
|
(#\# (push-thing (if pad-type
|
|
(cons :index pad-type)
|
|
:index)))
|
|
(t (let ((code (find next-c directives :key #'format-code-name)))
|
|
(unless (typep code 'format-code)
|
|
(unknown start-i "substitution"))
|
|
(unless (or (not pad-type) (format-code-padder code))
|
|
(error "Format code %~A does not support padding" next-c))
|
|
(push-thing (if pad-type (cons code pad-type) code)))))))
|
|
(#\\
|
|
(ensure-next-char i "escape sequence")
|
|
(push-string (subseq format-string start i))
|
|
(push-string
|
|
(case (aref format-string (1+ i))
|
|
(#\\ "\\")
|
|
(#\n (string #\Newline))
|
|
(#\t (string #\Tab))
|
|
(#\0 (string #\Nul))
|
|
(t (unknown i "escape sequence"))))
|
|
(setq start (+ i 2)
|
|
i (1+ i)))))
|
|
(push-string (subseq format-string start))
|
|
out)))
|
|
|
|
(defclass option-format-string (clingon:option)
|
|
((directives :accessor option-format-string-directives
|
|
:type list
|
|
:initarg :directives
|
|
:documentation "The format directives to use when parsing.")
|
|
(format-string :accessor option-format-string-format-string
|
|
:type string
|
|
:initform ""
|
|
:documentation "The used-passed format string."))
|
|
(:default-initargs :parameter "FORMAT-CONTROL")
|
|
(:documentation "Option that takes a format string."))
|
|
|
|
(defmethod clingon:initialize-option ((option option-format-string) &key)
|
|
(setf (option-format-string-format-string option)
|
|
(clingon:option-initial-value option))
|
|
(call-next-method))
|
|
|
|
(defmethod clingon:derive-option-value ((option option-format-string) arg &key)
|
|
(setf (option-format-string-format-string option) arg))
|
|
|
|
(defmethod clingon:finalize-option ((option option-format-string) &key)
|
|
(parse-format-string (option-format-string-format-string option)
|
|
(option-format-string-directives option)))
|
|
|
|
(defmethod clingon:make-option ((kind (eql :format-string)) &rest args)
|
|
(apply #'make-instance 'option-format-string args))
|
|
|
|
(defun number-length (n &optional (base 10))
|
|
"Return the number of digits in N when represented in BASE. If N is ngeative,
|
|
add one to the result."
|
|
(if (zerop n)
|
|
1
|
|
(+ (floor (log (abs n) base)) (if (minusp n) 2 1))))
|
|
|
|
(defun format-object (stream control-obj obj
|
|
&key (index 1) (max-index 1)
|
|
(max-index-length (number-length max-index))
|
|
extra-args)
|
|
"Format the object OBJ to STREAM according to CONTROL-OBJECT (which is from
|
|
parse-format-string)."
|
|
(dolist (part control-obj)
|
|
(cond
|
|
((eq :index part)
|
|
(format stream "~A" index))
|
|
((and (consp part) (eq :index (car part)))
|
|
(case (car part)
|
|
(:left (format stream "~VD" max-index-length index))
|
|
(:right (format stream "~V@<~D~>" max-index-length index))
|
|
(t (format stream "~A" index))))
|
|
((stringp part)
|
|
(format stream "~A" part))
|
|
((and (consp part))
|
|
(with-slots (padder action) (car part)
|
|
(funcall padder stream (cdr part)
|
|
(with-output-to-string (tmp-output)
|
|
(apply action tmp-output obj extra-args))
|
|
obj)))
|
|
(t (funcall (format-code-action part) stream obj)))))
|
|
|
|
(defun format-list (stream control-obj objs
|
|
&key (indices t) extra-action extra-args)
|
|
"Format a list of objects OBJS with format-object."
|
|
(if (eq t indices)
|
|
(loop with max-index = (length objs)
|
|
with max-index-length = (number-length max-index)
|
|
for obj in objs
|
|
for i upfrom 1
|
|
do (format-object stream control-obj obj
|
|
:index i :max-index max-index
|
|
:max-index-length max-index-length
|
|
:extra-args extra-args)
|
|
when extra-action
|
|
do (funcall extra-action obj))
|
|
(loop with max-index = (reduce #'max indices :initial-value 0)
|
|
with max-index-length = (number-length max-index)
|
|
with objs-arr = (coerce objs 'vector)
|
|
for index in indices
|
|
do (format-object stream control-obj (aref objs-arr index)
|
|
:index (1+ index) :max-index max-index
|
|
:max-index-length max-index-length
|
|
:extra-args extra-args)
|
|
when extra-action
|
|
do (funcall extra-action (aref objs-arr index)))))
|
|
|
|
(defun print-format-info (stream &rest name-directive-pairs)
|
|
(format stream "~
|
|
Format strings use C-style and printf-style escape sequences. Each character
|
|
other than one of those with a special meaning noted below is copied to the
|
|
output verbatim. The recognized C-style escapes sequences are:
|
|
\"\\0\" - null byte
|
|
\"\\n\" - newline
|
|
\"\\t\" - tab character
|
|
\"\\\\\" - literal backslash~%~%")
|
|
(loop for (name directive . rest) = name-directive-pairs then rest
|
|
for first = t then nil
|
|
while name
|
|
when first
|
|
do (format stream "~
|
|
(Sequences with a \"*\" before them support padding by putting a < or > after
|
|
the initial % character)~%")
|
|
do (format stream "~
|
|
The recognized printf-style sequences for ~A are:
|
|
\"%%\" - a literal %
|
|
*\"%#\" - the index of the current item (used when prompting)~%" name)
|
|
do (dolist (code (sort (copy-list directive) #'char-lessp
|
|
:key #'format-code-name))
|
|
(with-slots (name doc padder) code
|
|
(format stream " ~:[ ~;*~]\"%~A\"~@[ - ~A~]~%"
|
|
padder name doc)))
|
|
when rest
|
|
do (terpri stream)))
|
|
|
|
(defun make-fixed-with-padder (width)
|
|
"Return a padder (for a format-code)"
|
|
(lambda (stream pad-type text obj)
|
|
(declare (ignore obj))
|
|
(case pad-type
|
|
(:left (format stream "~V@<~A~>" width text))
|
|
(:right (format stream "~V<~A~>" width text))
|
|
(t (format stream "~A" text)))))
|
|
|
|
(defvar *format-switch-base-two-base-ten* nil
|
|
"Switch the base 2 and base 10 for codes.")
|
|
|
|
(defparameter *trashinfo-formatters*
|
|
(list
|
|
(make-format-code
|
|
:name #\o
|
|
:action (lambda (stream info)
|
|
(format stream "~A" (trashinfo-original-path info :resolve t)))
|
|
:doc "the (o)riginal path (always absolute)")
|
|
(make-format-code
|
|
:name #\O
|
|
:action (lambda (stream info)
|
|
(format stream "~A" (trashinfo-original-path info :normalize t)))
|
|
:doc "the (o)riginal path (possibly relative)")
|
|
(make-format-code
|
|
:name #\n
|
|
:action (lambda (stream info)
|
|
(format stream "~A" (file-or-dir-namestring
|
|
(trashinfo-original-path info))))
|
|
:doc "the original (n)ame")
|
|
(make-format-code
|
|
:name #\d
|
|
:action (lambda (stream info)
|
|
(format stream "~A" (trashinfo-trash-directory info)))
|
|
:doc "the trash (d)irectory")
|
|
(make-format-code
|
|
:name #\i
|
|
:action (lambda (stream info)
|
|
(format stream "~A" (trashinfo-info-file info)))
|
|
:doc "the trash(i)nfo file path")
|
|
(make-format-code
|
|
:name #\c
|
|
:action (lambda (stream info)
|
|
(format stream "~A" (trashinfo-trashed-file info)))
|
|
:doc "the (c)urrent (trashed) path")
|
|
(make-format-code
|
|
:name #\u
|
|
:action (lambda (stream info)
|
|
(format stream "~A" (local-time:timestamp-to-unix
|
|
(trashinfo-deletion-date info))))
|
|
:doc "the time the file was trashed (in (u)TC seconds)")
|
|
(make-format-code
|
|
:name #\t
|
|
:action (lambda (stream info)
|
|
(local-time:format-timestring
|
|
stream (trashinfo-deletion-date info)
|
|
:format local-time:+asctime-format+))
|
|
:doc "the (t)ime the file was trashed (pretty-printed local time)")
|
|
(make-format-code
|
|
:name #\s
|
|
:action (lambda (stream info)
|
|
(format stream "~A" (trashinfo-size info)))
|
|
:doc "the file's (s)size in bytes")
|
|
(make-format-code
|
|
:name #\h
|
|
:action (lambda (stream info)
|
|
(format stream "~A"
|
|
(format-size (trashinfo-size info)
|
|
*format-switch-base-two-base-ten*)))
|
|
:padder (make-fixed-with-padder 9)
|
|
:doc "the file's size with a (h)uman readable suffix (powers of 10)")
|
|
(make-format-code
|
|
:name #\H
|
|
:action (lambda (stream info)
|
|
(format stream "~A"
|
|
(format-size (trashinfo-size info)
|
|
(not *format-switch-base-two-base-ten*))))
|
|
:padder (make-fixed-with-padder 10)
|
|
:doc "the file's size with a (H)uman readable suffix (power of 2)")))
|
|
|
|
(defun trashinfo-list-size (infos)
|
|
"Return the sum of the sizes of each trashinfo in INFOS."
|
|
(loop for info in infos
|
|
summing (or (trashinfo-size info) 0)))
|
|
|
|
(defparameter *directory-formatters*
|
|
(list
|
|
(make-format-code
|
|
:name #\p
|
|
:action (lambda (stream path-and-infos)
|
|
(format stream "~A" (uiop:native-namestring
|
|
(uiop:ensure-directory-pathname
|
|
(car path-and-infos)))))
|
|
:doc "the directory's (p)ath (with a trailing slash)")
|
|
(make-format-code
|
|
:name #\s
|
|
:action (lambda (stream path-and-infos)
|
|
(format stream "~D" (trashinfo-list-size (cdr path-and-infos))))
|
|
:doc "the directory's (s)ize (in bytes)")
|
|
(make-format-code
|
|
:name #\h
|
|
:action (lambda (stream path-and-infos)
|
|
(format stream "~A" (format-size
|
|
(trashinfo-list-size (cdr path-and-infos))
|
|
*format-switch-base-two-base-ten*)))
|
|
:padder (make-fixed-with-padder 9)
|
|
:doc "the directory's size with a (h)uman readable suffix (powers of 10)")
|
|
(make-format-code
|
|
:name #\H
|
|
:action (lambda (stream path-and-infos)
|
|
(format stream "~A"
|
|
(format-size (trashinfo-list-size (cdr path-and-infos))
|
|
(not *format-switch-base-two-base-ten*))))
|
|
:padder (make-fixed-with-padder 10)
|
|
:doc "the directory's size with a (H)uman readable suffix (powers of 2)")
|
|
(make-format-code
|
|
:name #\c
|
|
:action (lambda (stream path-and-infos)
|
|
(format stream "~D" (length (cdr path-and-infos))))
|
|
:doc "the (c)ount of files trashed in the directory")
|
|
(make-format-code
|
|
:name #\m
|
|
:action (lambda (stream path-and-infos)
|
|
(let ((infos (cdr path-and-infos)))
|
|
(format stream "~@[s~]" (or (null infos) (cdr infos)))))
|
|
:doc "nothing if only one file was found in this directory, otherwise \"s\"")))
|
|
|
|
(defun print-clash-format-info (&optional (print-dir t) (stream t))
|
|
"Print format string information for clash to STREAM."
|
|
(apply #'print-format-info
|
|
stream
|
|
"trashed files" *trashinfo-formatters*
|
|
(when print-dir
|
|
(list "trash directories" *directory-formatters*))))
|