Fix some bugs and add date-based filtering

clash/clash.lisp

@@ -8,7 +8,10 @@
                 #:trashinfo-trashed-file
                 #:trashinfo-deletion-date)
   (:import-from #:cl-xdg-trash/mountpoints
-                #:file-or-dir-namestring)
+                #:file-or-dir-namestring
+                #:ensure-nonwild-pathname)
+  (:import-from #:cl-xdg-trash/directorysizes
+                #:trashed-file-size)
   (:use #:cl)
   (:export #:toplevel))
 
@@ -20,6 +23,212 @@
                (call-next-method command str-stream))))
     (format stream "~A" (subseq msg 0 (1- (length msg))))))
 
+
+;; Datetime stuff
+(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)
+             (with-slots (source pos message) condition
+               (format
+                stream "Failed to parse date ~S~@[ at position ~A~]: ~A"
+                source pos message))))
+  (: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-date-range (clingon:option)
+  ((ranges :accessor option-date-range-ranges
+           :initarg ranges
+           :initform nil
+           :type list
+           :documentation "List of conses of local-time:timestamps representing
+date ranges.."))
+  (:default-initargs :parameter "RANGE"))
+
+(defmethod clingon:derive-option-value ((option option-date-range) arg &key)
+  (push (parse-date-range arg) (option-date-range-ranges option))
+  (option-date-range-ranges option))
+
+(defmethod clingon:make-option ((kind (eql :date-range)) &rest args)
+  (apply #'make-instance 'option-date-range args))
+
 
 ;; Filtering
 (defun clingon-filtering-options ()
@@ -65,7 +274,13 @@
     :key :format
     :description "format to print results in"
     :short-name #\f
-    :long-name "format")))
+    :long-name "format")
+   (clingon:make-option
+    :date-range
+    :key :date-ranges
+    :description "range of dates to consider in search"
+    :short-name #\R
+    :long-name "date-range")))
 
 (declaim (inline compare-trashinfo-to-string))
 (defun compare-trashinfo-to-string (trashinfo filter full-path exact
@@ -84,9 +299,7 @@ options."
   "Compare TRASHINFO's name or path to FILTER, which is a cl-ppcre scanner."
   (let* ((orig-path (trashinfo-original-path trashinfo))
          (target (if full-path orig-path (file-or-dir-namestring orig-path))))
-    (destructuring-bind (start &optional end &rest ignore)
-        (multiple-value-list (cl-ppcre:scan filter target))
-      (declare (ignore ignore))
+    (multiple-value-bind (start end) (cl-ppcre:scan filter target)
       (and start
            (or (not exact)
                (and (= start 0) (= end (length target))))))))
@@ -116,65 +329,85 @@ string."
 
 (defun list-nonexcluded-trash-dirs (cmd)
   "Return a list of all trash directories, except those excluded by CMD."
-  (set-difference (cl-xdg-trash:list-trash-directories)
-                  (clingon:getopt cmd :ignored-trashes)
-                  :test #'uiop:pathname-equal))
+  (append (set-difference (cl-xdg-trash:list-trash-directories)
+                          (clingon:getopt cmd :ignored-trashes)
+                          :test #'uiop:pathname-equal)
+          (mapcar #'ensure-nonwild-pathname
+                  (clingon:getopt cmd :extra-trashes))))
+
+(defun limit-trashinfo-dates-for-cmd (cmd trashinfos)
+  (let ((ranges (clingon:getopt cmd :date-ranges)))
+    (if (not ranges)
+        trashinfos
+        (delete-if (lambda (info)
+                     (not (timestamp-in-ranges (trashinfo-deletion-date info)
+                                               ranges)))
+                   trashinfos))))
 
 (defun list-trashinfos-for-cmd (cmd)
   "List trashinfos for the command CMD."
   (let ((args (clingon:command-arguments cmd)))
     (when (cdr args)
       (clingon:print-usage-and-exit cmd t))
-    (if (not (car args))
-        (cl-xdg-trash:list-trashed-files (list-nonexcluded-trash-dirs cmd))
-        (let ((filter (car args))
-              (strings (clingon:getopt cmd :strings))
-              (exact (clingon:getopt cmd :exact))
-              (full-path (clingon:getopt cmd :full-path))
-              (case-insensitive (clingon:getopt cmd :case-insensitive))
-              (invert (clingon:getopt cmd :invert)))
-          (filter-trashinfos-by
-           (cl-xdg-trash:list-trashed-files
-            (list-nonexcluded-trash-dirs cmd))
-           filter
-           :regexp (not strings)
-           :exact exact
-           :full-path full-path
-           :case-insensitive case-insensitive
-           :invert invert)))))
+    (limit-trashinfo-dates-for-cmd
+     cmd
+     (if (not (car args))
+         (cl-xdg-trash:list-trashed-files (list-nonexcluded-trash-dirs cmd))
+         (let ((filter (car args))
+               (strings (clingon:getopt cmd :strings))
+               (exact (clingon:getopt cmd :exact))
+               (full-path (clingon:getopt cmd :full-path))
+               (case-insensitive (clingon:getopt cmd :case-insensitive))
+               (invert (clingon:getopt cmd :invert)))
+           (filter-trashinfos-by
+            (cl-xdg-trash:list-trashed-files
+             (list-nonexcluded-trash-dirs cmd))
+            filter
+            :regexp (not strings)
+            :exact exact
+            :full-path full-path
+            :case-insensitive case-insensitive
+            :invert invert))))))
 
 
 ;; Formatting
 (defparameter *trashinfo-formatters*
-  `((#\o . ,(lambda (stream info)
-              "the (o)riginal path"
-              (format stream "~A" (trashinfo-original-path info))))
-    (#\n . ,(lambda (stream info)
-              "the original (n)ame"
-              (format stream "~A" (file-or-dir-namestring
-                                   (trashinfo-original-path info)))))
-    (#\d . ,(lambda (stream info)
-              "the trash (d)irectory"
-              (format stream "~A" (trashinfo-trash-directory info))))
-    (#\i . ,(lambda (stream info)
-              "the trash(i)nfo file path"
-              (format stream "~A" (trashinfo-info-file info))))
-    (#\c . ,(lambda (stream info)
-              "the (c)urrent (trashed) path"
-              (format stream "~A" (trashinfo-trashed-file info))))
-    (#\u . ,(lambda (stream info)
-              "the time the file was trashed (in (u)TC seconds)"
-              (format stream "~A" (local-time:timestamp-to-unix
-                                   (trashinfo-deletion-date info)))))
-    (#\t . ,(lambda (stream info)
-              "the (t)ime the file was trashed (pretty-printed local time)"
-              (local-time:format-timestring
-               stream (trashinfo-deletion-date info)
-               :format local-time:+asctime-format+)))
-    (#\% . ,(lambda (stream info)
-              "a liternal %"
-              (declare (ignore info))
-              (format stream "%")))))
+  `((#\# :index
+         "the index of the current file (used when prompting for files)")
+    (#\o ,(lambda (stream info)
+            (format stream "~A" (trashinfo-original-path info)))
+         "the (o)riginal path")
+    (#\n ,(lambda (stream info)
+            (format stream "~A" (file-or-dir-namestring
+                                 (trashinfo-original-path info))))
+         "the original (n)ame")
+    (#\d ,(lambda (stream info)
+            (format stream "~A" (trashinfo-trash-directory info)))
+         "the trash (d)irectory")
+    (#\i ,(lambda (stream info)
+            (format stream "~A" (trashinfo-info-file info)))
+         "the trash(i)nfo file path")
+    (#\c ,(lambda (stream info)
+            (format stream "~A" (trashinfo-trashed-file info)))
+         "the (c)urrent (trashed) path")
+    (#\u ,(lambda (stream info)
+            (format stream "~A" (local-time:timestamp-to-unix
+                                 (trashinfo-deletion-date info))))
+         "the time the file was trashed (in (u)TC seconds)")
+    (#\t ,(lambda (stream info)
+            (local-time:format-timestring
+             stream (trashinfo-deletion-date info)
+             :format local-time:+asctime-format+))
+         "the (t)ime the file was trashed (pretty-printed local time)")
+    (#\t ,(lambda (stream info)
+            (format stream "~A" (trashed-file-size
+                                 (trashinfo-trash-directory info)
+                                 (trashinfo-name info))))
+         "the file's (s)size")
+    (#\% ,(lambda (stream info)
+            (declare (ignore info))
+            (format stream "%"))
+         "a liternal %")))
 
 (defun process-format-string (format-string)
   "Process FORMAT-STRING into a list of string and functions."
@@ -202,9 +435,9 @@ string."
           (#\%
            (ensure-next-char i "substitution")
            (push-string (subseq format-string start i))
-           (let ((fun (cdr (assoc (aref format-string (1+ i))
-                                  *trashinfo-formatters*))))
-             (unless (functionp fun)
+           (let ((fun (second (assoc (aref format-string (1+ i))
+                                     *trashinfo-formatters*))))
+             (unless fun
                (unknown i "substitution"))
              (push-thing fun))
            (setq start (+ i 2)
@@ -224,13 +457,16 @@ string."
       (push-string (subseq format-string start))
       out)))
 
-(defun format-trashinfo (stream format-object info)
+(defun format-trashinfo (stream format-object info &key (index 1))
   "Format the trashinfo INFO to STREAM accoring to FORMAT-OBJECT (which is from
 process-format-string)."
   (dolist (part format-object)
-    (if (stringp part)
-        (format stream "~A" part)
-        (funcall part stream info))))
+    (cond
+      ((eq :index part)
+       (format stream "~A" index))
+      ((stringp part)
+       (format stream "~A" part))
+      (t (funcall part stream info)))))
 
 (defun print-format-info (&optional (stream t))
   (format stream "~
@@ -243,8 +479,8 @@ output verbatim. The recognized C-style escapes sequences are:
   \"\\\\\" - literal backslash
 The recognizes printf-style sequences are (parenthesis denote the mnemonic):~%")
   (dolist (entry *trashinfo-formatters*)
-    (let ((char (car entry))
-          (doc (documentation (cdr entry) t)))
+    (let ((char (first entry))
+          (doc (third entry)))
       (format stream "  \"%~A\" - ~A~%" char doc))))
 
 
@@ -289,30 +525,121 @@ The recognizes printf-style sequences are (parenthesis denote the mnemonic):~%")
 
 ;; List command
 (defun list/handler (cmd)
-  "Toplevel for the \"list\" subcommand."
+  "Handler for the \"list\" subcommand."
   (if (clingon:getopt cmd :print-format-info)
       (print-format-info t)
       (let ((format (process-format-string (or (clingon:getopt cmd :format)
                                                "%t  %o\\n"))))
-        (dolist (info (sort-trashinfos-for-cmd
-                       (list-trashinfos-for-cmd cmd) cmd))
-          (format-trashinfo t format info)))))
+        (loop for info in (sort-trashinfos-for-cmd
+                           (list-trashinfos-for-cmd cmd) cmd)
+              for i upfrom 1
+              do (format-trashinfo t format info :index i)))))
 
 (defun list/options ()
   "Return options for the \"list\" subcommand."
   (append
    (clingon-filtering-options)
-   (clingon-sort-options)))
+   (clingon-sort-options)
+   (list
+    (clingon:make-option
+     :list/filepath
+     :key :extra-trashes
+     :description "include additional trashes"
+     :short-name #\c
+     :long-name "include-trash"))))
 
 (defun list/command ()
   "Return the Clingon command for the \"list\" subcommand."
   (clingon:make-command
    :name "list"
    :description "list files in trash directories"
-   :usage "[pattern]"
+   :usage "[options] [pattern]"
    :options (list/options)
    :handler #'list/handler))
 
+
+;; Put command
+(defun put/handler (cmd)
+  "Handler for the \"put\" subcommand."
+  (let ((no-cross-device (clingon:getopt cmd :no-cross-device))
+        (ignored-dirs (clingon:getopt cmd :ignored-trashes))
+        (trash-directory (clingon:getopt cmd :trash-directory)))
+    (dolist (file (clingon:command-arguments cmd))
+      (handler-case
+          (cl-xdg-trash:trash-file file :no-cross-device no-cross-device
+                                        :ignored-trash-dirs ignored-dirs
+                                        :trash-directory trash-directory)
+        ;; in case of an error, just notify the user and continue
+        (error (e)
+          (format *error-output* "~&~A~&" e))))))
+
+(defun put/options ()
+  "Return options for the \"put\" subcommand."
+  (list
+   (clingon:make-option
+    :filepath
+    :key :trash-directory
+    :description "force trashing to a specific directory"
+    :long-name "trash-directory")
+   (clingon:make-option
+    :flag
+    :key :no-cross-device
+    :description "don't trash files to directories on different devices"
+    :short-name #\n
+    :long-name "no-cross-device")))
+
+(defun put/command ()
+  "Return the Clingon command for the \"put\" subcommand"
+  (clingon:make-command
+   :name "put"
+   :aliases '("trash")
+   :description "move files to the trash"
+   :usage "[-n|--no-cross-device] [--trash-directory=DIR] [files...]"
+   :options (put/options)
+   :handler #'put/handler))
+
+
+;; Restore command
+
+(defun restore/handler (cmd)
+  "Handler for the \"restore\" subcommand."
+  (le))
+
+(defun restore/options ()
+  "Return options for the \"restore\" subcommand."
+  (append
+   (clingon-filtering-options)
+   (clingon-sort-options)
+   (list
+    (clingon:make-option
+     :flag
+     :key :all
+     :description "restore all files that match the pattern"
+     :short-name #\a
+     :long-name "all")
+    (clingon:make-option
+     :list/integer
+     :key :indices
+     :description
+     "restore the Nth file that matched the pattern (after sorting)"
+     :short-name #\n
+     :long-name "nth")
+    (clingon:make-option
+     :flag
+     :key :dont-prompt-only-one
+     :descrition "don't prompt if the pattern matches only one file"
+     :short-name #\O
+     :long-name "dont-prompt-only-one"))))
+
+(defun restore/command ()
+  "Rethrn the Clingon command for the \"restore\" subcommand."
+  (clingon:make-command
+   :name "restore"
+   :descrition "move files out of the trash"
+   :usage "[options] [pattern]"
+   :options (restore/options)
+   :handler #'restore/handler))
+
 
 ;; Toplevel command
 (defun toplevel/options ()
@@ -334,7 +661,8 @@ The recognizes printf-style sequences are (parenthesis denote the mnemonic):~%")
    :license "GPL3"
    :authors '("Alexander Rosenberg <zanderpkg@pm.me>")
    :options (toplevel/options)
-   :sub-commands (list (list/command))
+   :sub-commands (list (list/command)
+                       (put/command))
    :handler #'(lambda (cmd)
                 (clingon:print-usage-and-exit cmd t))))