Finish all features (for now)

README.md

@@ -1,5 +1,7 @@
-# cl-xdg-trash
+# cl-xdg-trash (and clash)
 
-`cl-xdg-trash` is a Common Lisp interface to the standard XDG trash
+This repository contains two different (related) projects. The first is
-specification. You can find a copy of the specification on the [freedesktop.org
+`cl-xdg-trash`, which is a Common Lisp interface to the XDG trash
-git](https://cgit.freedesktop.org/xdg/xdg-specs/tree/trash).
+specification. The second is `clash`, which is a command-line that relies on
+`cl-xdg-trash`. Each of them has their own `README.md` file, so check those out
+for more information and usage instructions.

cl-xdg-trash/README.md

@@ -0,0 +1,25 @@
+# cl-xdg-trash
+
+`cl-xdg-trash` is a Common Lisp interface to the standard XDG trash
+specification. You can find a copy of the specification
+[here](https://www.freedesktop.org/wiki/Specifications/trash-spec/).
+
+## Use
+`cl-xdg-trash` depends on `local-time`, `uiop`, `trivial-features`, and
+`osicat`. You'll need to obtain them before you try to use `cl-xdg-trash`.
+
+To use, put this somewhere in your [asdf](https://asdf.common-lisp.dev/) load
+path and evaluate:
+```lisp
+(asdf:load-system :cl-xdg-trash)
+```
+You can also use [Quicklisp](https://www.quicklisp.org/beta/) (just for loading,
+you still need to download `cl-xdg-trash` manually):
+```lisp
+(ql:quickload :cl-xdg-trash)
+```
+Using `Quicklisp` has the advantage of automatically downloading and building
+dependencies.
+
+To get started, have a look at `trash.lisp` for the main end-user functions. To
+find a list of all exported function, see `package.lisp`.

cl-xdg-trash/cl-xdg-trash.asd

@@ -5,7 +5,7 @@
   :maintainer "Alexander Rosenberg <zanderpkg@pm.me>"
   :homepage "https://git.zander.im/Zander671/cl-xdg-trash"
   :license "GPL3"
-  :depends-on (#:local-time #:uiop #:trivial-features :osicat)
+  :depends-on (#:local-time #:uiop #:trivial-features #:osicat)
   :serial t
   :components
   ((:file "package")
@@ -16,7 +16,7 @@
    (:file "trash"))
   :long-description
   #.(uiop:read-file-string
-     (uiop:subpathname *load-pathname* "../README.md")))
+     (uiop:subpathname *load-pathname* "README.md")))
 
 (defsystem #:cl-xdg-trash/tests
   :description "Tests for cl-xdg-trash"

cl-xdg-trash/directorysizes.lisp

@@ -1,15 +1,5 @@
 (in-package :cl-xdg-trash/directorysizes)
 
-(declaim (ftype (function ((or string pathname)) pathname)
-                directory-as-file-pathname))
-(defun directory-as-file-pathname (path)
-  "Return PATH as a file, not a directory pathname."
-  (let ((path (ensure-nonwild-pathname path)))
-    (if (uiop:file-pathname-p path)
-        path
-        (make-pathname :name (file-or-dir-namestring path) :type nil
-                       :directory (butlast (pathname-directory path))))))
-
 (declaim (ftype (function ((or string pathname) &optional t) integer) file-size))
 (defun file-size (path &optional (no-errors t))
   "Return the size of the file (inode) named by PATH."
@@ -95,12 +85,6 @@ part of STRING."
         do (with-slots (size mtime) entry
              (format stream "~A ~A ~A~%" size mtime (url-encode name)))))
 
-(declaim (ftype (function ((or string pathname)) pathname) parent-directory))
-(defun parent-directory (path)
-  "Return the parent directory of PATH."
-  (uiop:pathname-parent-directory-pathname
-   (uiop:ensure-directory-pathname path)))
-
 (defmacro with-atomic-write ((stream path) &body body)
   "Evaluate BODY with STREAM bound to a stream that will write to a temporary
 file. If execution is successful, rename this temporary file to PATH, replacing

cl-xdg-trash/package.lisp

@@ -28,8 +28,11 @@
   (:import-from #:cl-xdg-trash/mountpoints
                 #:file-or-dir-namestring
                 #:ensure-nonwild-pathname
-                #:remove-suffix)
+                #:remove-suffix
-  (:export #:trashinfo-format-error
+                #:find-filesystem-root)
+  (:export #:directory-as-file-pathname
+           #:parent-directory
+           #:trashinfo-format-error
            #:trashinfo-format-error-message
            #:trashinfo-format-error-line-numer
            #:trashinfo-format-error-context
@@ -58,9 +61,10 @@
                 #:url-encode
                 #:url-decode)
   (:import-from #:cl-xdg-trash/trashinfo
-                #:compute-trashinfo-source-file)
+                #:compute-trashinfo-source-file
-  (:export #:directory-as-file-pathname
+                #:parent-directory
-           #:read-directorysizes-file
+                #:directory-as-file-pathname)
+  (:export #:read-directorysizes-file
            #:prase-directorysizes
            #:trashed-file-size
            #:calculate-directorysizes-path))
@@ -80,4 +84,5 @@
            #:list-trashed-files
            #:restore-file
            #:empty-file
-           #:empty-all))
+           #:empty-all
+           #:trash-directory-size))

cl-xdg-trash/trash.lisp

@@ -183,7 +183,7 @@ ROOT. IGNORED-TRASH-DIRS must be directory paths that are not wild!"
                          ht))))
     (if (and (path-in-home-directory-p res-path)
              (uiop:pathname-equal
-              (find-filesystem-root (user-homedir-pathname)) root))
+              (find-filesystem-root (user-home-trash-directory)) root))
         home-trash
         (or (maybe-create-toplevel-trash-dir root ignored-trash-dirs)
             home-trash))))
@@ -282,8 +282,8 @@ specific directory."
                   (ensure-nonwild-pathname elt :ensure-directory t))
               trash-directories)))
 
-(declaim (ftype (function (pathname) list) list-trashed-files-for-directory))
+(declaim (ftype (function (pathname t) list) list-trashed-files-for-directory))
-(defun list-trashed-files-for-directory (trash-directory)
+(defun list-trashed-files-for-directory (trash-directory include-missing)
   "Return a list of trashinfo objects for every trashed file in
 TRASH-DIRECTORY."
   (let ((info-dir (uiop:ensure-directory-pathname
@@ -297,18 +297,24 @@ TRASH-DIRECTORY."
                                           (subseq
                                            name 0 (- (length name)
                                                      (length ".trashinfo"))))))
-                          (when (probe-file
+                          (when (or include-missing
-                                 (trashinfo-trashed-file trashinfo))
+                                    (probe-file
+                                     (trashinfo-trashed-file trashinfo)))
                             (list trashinfo)))
                       (trashinfo-format-error ())))))
             (uiop:directory-files info-dir))))
 
-(declaim (ftype (function (&optional (or pathname string list)) list)
+(declaim (ftype (function (&optional (or pathname string list) t) list)
                 list-trashed-files))
-(defun list-trashed-files (&optional (trash-directories (list-trash-directories)))
+(defun list-trashed-files
+    (&optional (trash-directories (list-trash-directories))
+       include-missing)
   "Return a list of trashinfo objects for each trashed file in
-TRASH-DIRECTORIES. TRASH-DIRECTORIES can also be a single path."
+TRASH-DIRECTORIES. TRASH-DIRECTORIES can also be a single path. With
-  (mapcan #'list-trashed-files-for-directory
+INCLUDE-MISSING, also include trashinfo files that are missing their
+corresponding trashed file."
+  (mapcan (lambda (dir)
+            (list-trashed-files-for-directory dir include-missing))
           (normalize-trash-directories trash-directories)))
 
 (declaim (ftype (function (trashinfo &key (:target (or string pathname))
@@ -317,7 +323,8 @@ TRASH-DIRECTORIES. TRASH-DIRECTORIES can also be a single path."
                           t)
                 restore-file))
 (defun restore-file (trashinfo &key
-                                 (target (trashinfo-original-path trashinfo))
+                                 (target (trashinfo-original-path trashinfo
+                                                                  :resolve t))
                                  (update-size-cache t)
                                  no-cross-device)
   "Restore the file pointed to by TRASHINFO. If UPDATE-SIZE-CACHE is non-nil
@@ -372,3 +379,13 @@ DRY-RUN just print the directories that will be removed without actually doing
 anything."
   (dolist (trashinfo (list-trashed-files trash-directories))
     (empty-file trashinfo :dry-run dry-run)))
+
+(declaim (ftype (function ((or string pathname)) (integer 0))
+                trash-directory-size))
+(defun trash-directory-size (directory)
+  "Return the size of all files trashed in DIRECTORY."
+  (loop for info in (list-trashed-files directory)
+        summing (or (trashed-file-size
+                     (trashinfo-trash-directory info)
+                     (trashinfo-name info))
+                    0)))

cl-xdg-trash/trashinfo.lisp

@@ -1,5 +1,38 @@
 (in-package :cl-xdg-trash/trashinfo)
 
+(declaim (ftype (function ((or string pathname)) pathname)
+                guess-trash-directory-root))
+(defun guess-trash-directory-root (trash-directory)
+  "Guess the root of TRASH-DIRECTORY."
+  (let ((home (cl-xdg-trash:user-home-trash-directory)))
+    (if (uiop:pathname-equal (ensure-nonwild-pathname trash-directory
+                                                      :ensure-directory t)
+                             home)
+        (parent-directory home)
+        (find-filesystem-root trash-directory))))
+
+(defun home-trash-p (trash-directory)
+  "Return non-nil if TRASH-DIRECTORY is the user's home trash directory."
+  (uiop:pathname-equal (ensure-nonwild-pathname
+                        trash-directory :ensure-directory t)
+                       (cl-xdg-trash:user-home-trash-directory)))
+
+(declaim (ftype (function ((or string pathname)) pathname)
+                directory-as-file-pathname))
+(defun directory-as-file-pathname (path)
+  "Return PATH as a file, not a directory pathname."
+  (let ((path (ensure-nonwild-pathname path)))
+    (if (uiop:file-pathname-p path)
+        path
+        (make-pathname :name (file-or-dir-namestring path) :type nil
+                       :directory (butlast (pathname-directory path))))))
+
+(declaim (ftype (function ((or string pathname)) pathname) parent-directory))
+(defun parent-directory (path)
+  "Return the parent directory of PATH."
+  (uiop:pathname-parent-directory-pathname
+   (uiop:ensure-directory-pathname path)))
+
 (define-condition trashinfo-format-error (parse-error)
   ((message :accessor trashinfo-format-error-message
             :initarg :message
@@ -34,8 +67,7 @@ trashinfo file belongs to.")
          :initarg :name
          :type string
          :documentation "The name of this trashinfo file without the extension.")
-   (original-path :reader trashinfo-original-path
+   (original-path :initarg :original-path
-                  :initarg :original-path
                   :type pathname
                   :documentation "Path to the original location of the file.")
    (deletion-date :reader trashinfo-deletion-date
@@ -45,6 +77,39 @@ trashinfo file belongs to.")
 trashed."))
   (:documentation "Represents a .trashinfo file."))
 
+(defmethod trashinfo-in-home-p ((trashinfo trashinfo))
+  (home-trash-p (trashinfo-trash-directory trashinfo)))
+
+(defun make-path-relative (root path)
+  "If PATH is absolute, make it relative to ROOT."
+  (if (uiop:relative-pathname-p path)
+      path
+      (let ((unix-root (uiop:unix-namestring
+                        (ensure-nonwild-pathname root :ensure-directory t)))
+            (unix-path (uiop:unix-namestring
+                        (ensure-nonwild-pathname path))))
+        (uiop:parse-unix-namestring
+         (if (uiop:string-prefix-p unix-root unix-path)
+             (subseq unix-path (length unix-root))
+             (subseq unix-path 1))))))
+
+(defmethod trashinfo-original-path ((trashinfo trashinfo)
+                                    &key resolve normalize)
+  (assert (not (and resolve normalize)) (resolve normalize)
+          "Only one of RESOVLE and NORMALIZE can be passed")
+  (with-slots (original-path trash-directory) trashinfo
+    (cond
+      (resolve
+       (merge-pathnames original-path
+                        (guess-trash-directory-root trash-directory)))
+      ((and normalize (trashinfo-in-home-p trashinfo))
+       (merge-pathnames original-path
+                        (parent-directory (cl-xdg-trash:user-home-trash-directory))))
+      (normalize
+       (make-path-relative (find-filesystem-root trash-directory)
+                           original-path))
+      (t original-path))))
+
 (defmethod print-object ((obj trashinfo) stream)
   (print-unreadable-object (obj stream :type t :identity t)
     (princ (trashinfo-name obj) stream)))
@@ -101,7 +166,8 @@ trashed file NAME in TRASH-DIRECTORY."
                                   :directory '(:relative "info"))
                    (ensure-nonwild-pathname trash-directory :ensure-directory t)))
 
-(declaim (ftype (function (pathname string stream &key (:source-file pathname))
+(declaim (ftype (function ((or string pathname) string stream
+                                                &key (:source-file pathname))
                           trashinfo)
                 parse-trashinfo-from-stream))
 (defun parse-trashinfo-from-stream
@@ -118,8 +184,11 @@ trashed file NAME in TRASH-DIRECTORY."
              :line-number 1 :source-file source-file
              :context first-line
              :message "First line should be \"[Trash Info]\"")))
-  (loop with path = nil
+  (loop with trash-directory = (ensure-nonwild-pathname trash-directory
+                                                        :ensure-directory t)
+        with path = nil
         with deletion-date = nil
+        with in-home = (home-trash-p trash-directory)
         for line-number upfrom 2
         for line = (read-line in nil)
         while (and line (not (and path deletion-date)))
@@ -128,7 +197,15 @@ trashed file NAME in TRASH-DIRECTORY."
           do (cond
                ((and (not path)
                      (string= line "Path" :end1 delim))
-                (setq path (url-decode line :start (1+ delim))))
+                (let ((found (ensure-nonwild-pathname
+                              (url-decode line :start (1+ delim)))))
+                  (unless (or in-home (uiop:relative-pathname-p found))
+                    (error 'trashinfo-format-error
+                           :line-number line-number :context line
+                           :source-file source-file
+                           :message
+                           "Absolute path outside of home trash directory"))
+                  (setq path found)))
                ((and (not deletion-date)
                      (string= line "DeletionDate" :end1 delim))
                 (handler-case
@@ -147,9 +224,11 @@ trashed file NAME in TRASH-DIRECTORY."
                       :context "" :source-file source-file
                       :message
                       "End-of-file without both \"Path\" and \"DeletionDate\"")
-               (return (make-instance 'trashinfo
+               (return (make-instance
+                        'trashinfo
                         :deletion-date deletion-date
-                                      :original-path path :name name
+                        :original-path (directory-as-file-pathname path)
+                        :name name
                         :trash-directory trash-directory)))))
 
 (declaim (ftype (function ((or pathname string) string) trashinfo)))
@@ -181,12 +260,14 @@ TRASH-DIRECTORY. If SOURCE-FILE is not provided, it will be calculated."
                 format-trashinfo))
 (defun format-trashinfo (trashinfo &optional stream)
   "Write the trashinfo file out to STREAM."
-  (with-slots (original-path deletion-date) trashinfo
+  (with-slots (deletion-date) trashinfo
     (format stream "[Trash Info]~%Path=~A~%DeletionDate=~A~%"
-            (url-encode original-path :safe-chars '(#\/))
+            (url-encode (uiop:unix-namestring
+                         (trashinfo-original-path trashinfo :normalize t))
+                        :safe-chars '(#\/))
             (format-trashinfo-timestamp deletion-date))))
 
-(declaim (ftype (function (pathname (or string pathname)) stream)
+(declaim (ftype (function ((or string pathname) (or string pathname)) stream)
                 open-trashinfo-for))
 (defun open-trashinfo-for (trash-directory path)
   (loop with trash-directory = (ensure-nonwild-pathname trash-directory
@@ -209,6 +290,15 @@ TRASH-DIRECTORY. If SOURCE-FILE is not provided, it will be calculated."
         until stream
         finally (return stream)))
 
+(declaim (ftype (function ((or pathname string) (or pathname string)) pathname)
+                make-original-path))
+(defun make-original-path (trash-directory path)
+  "Calculate what the original path for PATH is after it is trashed to
+TRASH-DIRECTORY."
+  (if (home-trash-p trash-directory)
+      (merge-pathnames path (cl-xdg-trash:user-home-trash-directory))
+      (make-path-relative (find-filesystem-root trash-directory) path)))
+
 (declaim (ftype (function (pathname (or pathname string)
                                     &optional local-time:timestamp)
                           trashinfo)
@@ -225,15 +315,19 @@ TRASH-DIRECTORY. Return a trashinfo object pointing to this file."
                     (close stream :abort t)
                     (signal e))))
           (let ((trashinfo
-                  (make-instance 'trashinfo
+                  (make-instance
-                                 :original-path (uiop:native-namestring
+                   'trashinfo
-                                                 (merge-pathnames path
+                   :original-path
-                                                                  (uiop:getcwd)))
+                   (directory-as-file-pathname
+                    (make-original-path trash-directory
+                                        (merge-pathnames path (uiop:getcwd))))
                    :name (remove-suffix
                           (file-or-dir-namestring
                            (pathname stream))
                           ".trashinfo")
-                                 :trash-directory trash-directory
+                   :trash-directory
+                   (ensure-nonwild-pathname trash-directory
+                                            :ensure-directory t)
                    :deletion-date deletion-date)))
             (format-trashinfo trashinfo stream)
             trashinfo))

cl-xdg-trash/url-encode.lisp

@@ -33,7 +33,7 @@
     (cons (integer #b11110000 #b11110111)
      (cons utf-8-middle-byte (cons utf-8-middle-byte (cons utf-8-middle-byte null))))))
 
-(declaim (ftype (function (character) list-of-code-points) utf-8-char))
+(declaim (ftype (function (character) utf-8-char) utf-8-encode-char))
 (defun utf-8-encode-char (char)
   "Encode CHAR, a character, to a list of bytes that make up its UTF-8
 representation."

clash/Makefile

@@ -1,6 +1,13 @@
 LISP=sbcl
 
-clash: clash.asd clash.lisp
+all: clash
+
+clash: clash.asd format.lisp parse-date.lisp clash.lisp
 	$(LISP) --eval '(ql:quickload :clash)' \
 			--eval '(asdf:make :clash)' \
 			--eval '(uiop:quit)'
+
+clean:
+	rm -f clash
+
+.PHONY: all clean

clash/README.md

@@ -0,0 +1,19 @@
+# clash
+
+`clash` is command-line tool for trashing and restoring files, as well as
+searching and deleting trashed files. It is inspired by the excellent
+[trash-cli](https://github.com/andreafrancia/trash-cli).
+
+Clash depends on `cl-xdg-trash`, `cl-ppcre`, and `clingon`. `cl-xdg-trash` is
+located in the same repository as `clash` and was developed alongside it.
+
+## Building
+To build `clash`, execute
+```sh
+make
+```
+from you're shell of choice.
+
+## Use
+A list of subcommands can be found with `clash -h`. Each subcommand can also
+take the `-h` flag to show documentation for that command.

clash/clash.asd

@@ -8,7 +8,12 @@
   :depends-on (#:cl-xdg-trash #:cl-ppcre #:clingon)
   :serial t
   :components
-  ((:file "clash"))
+  ((:file "format")
+   (:file "parse-date")
+   (:file "clash"))
   :build-operation "program-op"
   :build-pathname "clash"
-  :entry-point "clash:toplevel")
+  :entry-point "clash:toplevel"
+  :long-description
+  #.(uiop:read-file-string
+     (uiop:subpathname *load-pathname* "README.md")))

clash/format.lisp

@@ -0,0 +1,384 @@
+(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*))
+
+(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)))
+  "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)
+                    (funcall action tmp-output obj))
+                  obj)))
+      (t (funcall (format-code-action part) stream obj)))))
+
+(defun format-list (stream control-obj objs &optional (indices t) extra-action)
+  "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)
+            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)
+            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)))))
+
+(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))))
+    :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) t)))
+    :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)))))
+    :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)) t)))
+    :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*))))

clash/parse-date.lisp

@@ -0,0 +1,264 @@
+(defpackage clash/parse-date
+  (:documentation "Functions for parsing dates and date ranges.")
+  (:use #:cl)
+  (:export #:print-date-parsing-help
+           #:date-parse-error
+           #:date-parse-error-source
+           #:date-parse-error-position
+           #:dase-parse-error-message
+           #:parse-date-time
+           #:parse-date-range
+           #:timestamp-in-ranges
+           #:option-date-range
+           #:option-date-range-ranges))
+
+(in-package :clash/parse-date)
+
+(defun print-date-parsing-help (stream)
+  "Print information about date parsing to STREAM."
+  (format stream "~
+Dates can take one of the following forms (<THING> means THING is required,
+[THING] means it is optional):
+          \"now\"  - the current date and time
+        \"today\"* - midnight on the current day
+    \"yesterday\"* - midnight on the day before the current day
+     \"<NUMBER>\"  - integer seconds since midnight on January 1 1970 (UCT)
+  \"<M> <D> [Y]\"* - midnight on the Dth day of M (a month's name) of the Yth
+                   year, or the current year if Y is omitted (any of the
+                   whitespace between M, D, and Y can be replaced with a \"/\")
+In the above table, any format which has a * next to it can optionally be
+followed by a time in the format:
+  \"<HOUR>:<MINUTE>[:SECOND] [AM|PM]\"
+If SECOND is omitted, it is 0. If AM or PM are omitted, the time is assumed to
+be in 24-format. If the time is omitted entirely, midnight on the given date is
+assumed.
+
+Date ranges consist of one or two dates, separated by \"..\". If just one date
+is given without a separator, the pattern matches exactly that date (and
+time). If two dates are given, the patten matches any time between the two dates
+(inclusive of the bounds). If just a date of the form \"<START>..\" is given, it
+means \"any time after START\". Likewise, any date of the form \"..<END>\" means
+\"anytime before END\".
+
+Dates are supplied to commands that support then via the -R or --date-range
+flags. These flags can be given any number of times. Any item which matches at
+least one range given will match (that is, the union of all given dates).~%"))
+
+(define-condition date-parse-error (error)
+  ((source :accessor date-parse-error-source
+           :type string
+           :initarg :source
+           :documentation "The string that failed to parse.")
+   (pos :accessor date-parse-error-position
+        :type (or null integer)
+        :initarg :position
+        :initform nil
+        :documentation "The position of the error, or nil.")
+   (message :accessor date-parse-error-message
+            :type string
+            :initarg :message
+            :documentation "A message describing the error."))
+  (:report (lambda (condition stream)
+             (format
+              stream "Failed to parse date ~S~@[ at position ~A~]: ~A"
+              (date-parse-error-source condition)
+              (date-parse-error-position condition)
+              (date-parse-error-message condition))))
+  (:documentation "A condition representing a failure in parsing a date range."))
+
+(defparameter *month-conversion-table*
+  '((1 "january" "jan")
+    (2 "february" "feb")
+    (3 "march" "mar")
+    (4 "april" "apr")
+    (5 "may")
+    (6 "june" "jun")
+    (7 "july" "jly" "jul")
+    (8 "august" "aug")
+    (9 "september" "sep")
+    (10 "october" "oct")
+    (11 "november" "nov")
+    (12 "december" "dec")))
+
+(defun parse-month-string (str)
+  (loop for (num . text) in *month-conversion-table*
+        when (member str text :test 'equalp)
+          do (return num)))
+
+(defun add-time-registers (source stamp registers)
+  (destructuring-bind (hour minute second am-pm) (last registers 4)
+    (local-time:adjust-timestamp stamp
+      (offset :sec (parse-integer (or second "0")))
+      (offset :minute (parse-integer (or minute "0")))
+      (offset :hour
+              (if (not hour)
+                  0
+                  (cond
+                    ((or (not am-pm) (equalp am-pm "am")) (parse-integer hour))
+                    ((equalp am-pm "pm") (+ (parse-integer hour) 12))
+                    (t (error 'date-parse-error
+                              :source source
+                              :message
+                              (format nil "excpected \"AM\"/\"PM\", got: ~A"
+                                      am-pm)))))))))
+
+(defun current-year ()
+  "Return the current year."
+  (local-time:timestamp-year (local-time:now)))
+
+(defun local-today ()
+  "Return a timestamp representing the midnight today in local-time."
+  (local-time:adjust-timestamp! (local-time:now)
+    (set :hour 0)
+    (set :minute 0)
+    (set :sec 0)
+    (set :nsec 0)))
+
+(defparameter *date-parse-formats*
+  (let ((time-regexp
+          (format nil "(?:\\s|$)(?:\\s*([0-9]{1,2}):([0-9]{1,2})~
+                       (?::([0-9]{1,2}))?(?:\\s*(AM|PM))?)?"))
+        out)
+    (flet ((def (regexp func)
+             (push (cons (cl-ppcre:create-scanner
+                          (format nil "~A~A" regexp time-regexp)
+                          :extended-mode t :case-insensitive-mode t
+                          :multi-line-mode t)
+                         func)
+                   out))
+           (def-no-time (regexp func)
+             (push (cons (cl-ppcre:create-scanner regexp
+                                                  :extended-mode t :case-insensitive-mode t
+                                                  :multi-line-mode t)
+                         func)
+                   out)))
+      (def-no-time "^$"
+          (lambda (source registers)
+            (declare (ignore source registers))
+            (local-time:now)))
+      (def-no-time "[0-9]+"
+          (lambda (source registers)
+            (declare (ignore registers))
+            (local-time:unix-to-timestamp (parse-integer source))))
+      (def-no-time "now"
+          (lambda (source registers)
+            (declare (ignore source registers))
+            (local-time:now)))
+      (def "today"
+          (lambda (source registers)
+            (add-time-registers source
+                                (local-today)
+                                registers)))
+      (def "yesterday"
+          (lambda (source registers)
+            (add-time-registers source
+                                (local-time:adjust-timestamp! (local-today)
+                                  (offset :day -1))
+                                registers)))
+      ;; 2025/10/23 3:00 pm
+      (def "([0-9]+)(?:\\s+|/)([0-9]{1,2})(?:\\s+|/)([0-9]{1,2})"
+          (lambda (source registers)
+            (destructuring-bind (year month day &rest ignore) registers
+              (declare (ignore ignore))
+              (add-time-registers source
+                                  (local-time:encode-timestamp
+                                   0 0 0 0
+                                   (parse-integer day)
+                                   (parse-integer month)
+                                   (parse-integer year))
+                                  registers))))
+      ;; Oct 10/23 3:00 PM
+      (def "([A-Za-z]+)(?:\\s+|/)([0-9]{1,2})(?:(?:\\s+|/)([0-9]+))?"
+          (lambda (source registers)
+            (destructuring-bind (month-str day year &rest ignore)
+                registers
+              (declare (ignore ignore))
+              (let ((month (parse-month-string month-str)))
+                (unless month
+                  (error 'date-parse-error
+                         :source source
+                         :message (format nil "unknown month: ~S" month-str)))
+                (add-time-registers source
+                                    (local-time:encode-timestamp
+                                     0 0 0 0
+                                     (parse-integer day)
+                                     month
+                                     (if year
+                                         (parse-integer year)
+                                         (current-year)))
+                                    registers))))))))
+
+(defun parse-date-time (string)
+  "Parse date and time from STRING."
+  (dolist (entry *date-parse-formats*)
+    (destructuring-bind (scanner . func) entry
+      (multiple-value-bind (start end reg-starts reg-ends)
+          (cl-ppcre:scan scanner string)
+        (when (and (eql start 0)
+                   (eql end (length string)))
+          (return-from parse-date-time
+            (funcall func
+                     string
+                     (loop for s across reg-starts
+                           for e across reg-ends
+                           when (and s e)
+                             collect (subseq string s e)
+                           else
+                             collect nil))))))))
+
+(defun parse-date-range (string)
+  "Parse a date range from STRING."
+  (let ((sep (search ".." string)))
+    (when (not sep)
+      (error 'date-parse-error
+             :source string
+             :message "expected \"..\" to separate start and end date"))
+    (let ((second-sep (search ".." string :start2 (1+ sep))))
+      (when second-sep
+        (error 'date-parse-error :source string
+                                 :position second-sep
+                                 :message "multiple \"..\" found")))
+    (macrolet ((trim (str)
+                 `(string-trim '(#\Tab #\Space #\Newline) ,str)))
+      (cons (parse-date-time (trim (subseq string 0 sep)))
+            (parse-date-time (trim (subseq string (+ sep 2))))))))
+
+(defun timestamp-in-ranges (stamp ranges)
+  "Return non-nil if STAMP is in one of RANGES."
+  (some (lambda (range)
+          (destructuring-bind (start . end) range
+            (when (local-time:timestamp> start end)
+              (rotatef start end))
+            (and (local-time:timestamp>= stamp start)
+                 (local-time:timestamp<= stamp end))))
+        ranges))
+
+(defclass option-multi-parsed (clingon:option)
+  ((parser :accessor option-multi-parsed-parser
+           :initarg :parser
+           :type (function (string) t)
+           :documentation "The function that parses the passed value.")
+   (values :accessor option-multi-parsed-values
+           :initform nil
+           :type list
+           :documentation "The list of parsed values passed by the user."))
+  (:default-initargs :parameter "VALUE")
+  (:documentation "An option type that parses each value passed by the user."))
+
+(defmethod clingon:derive-option-value ((option option-multi-parsed) arg &key)
+  (with-slots (parser values) option
+    (push (funcall parser arg) values)))
+
+(defmethod clingon:finalize-option ((option option-multi-parsed) &key)
+  (with-slots (values) option
+    (setq values (nreverse values))))
+
+(defmethod clingon:make-option ((kind (eql :multi-parsed)) &rest args)
+  (apply #'make-instance 'option-multi-parsed args))
+
+(defclass option-date-range (option-multi-parsed)
+  ()
+  (:default-initargs :parameter "RANGE" :parser #'parse-date-range))
+
+(defmethod clingon:make-option ((kind (eql :date-range)) &rest args)
+  (apply #'make-instance 'option-date-range args))