Zander671/cl-xdg-trash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix some bugs and add date-based filtering

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-10-23 20:04:32 -07:00
parent 0f4a8f23f4
commit b834409684
5 changed files with 587 additions and 141 deletions
Download Patch File Download Diff File Expand all files Collapse all files

26
cl-xdg-trash/directorysizes.lisp
View File

@ -55,11 +55,12 @@ part of STRING."
while line while line
for (size mtime encoded-name) = (split-string line #\Space 3) for (size mtime encoded-name) = (split-string line #\Space 3)
for name = (url-decode encoded-name) for name = (url-decode encoded-name)
do (setf (gethash name out) when (and size mtime encoded-name)
(make-directorysizes-entry do (setf (gethash name out)
:size (parse-integer size) (make-directorysizes-entry
:mtime (parse-integer mtime) :size (parse-integer size)
:name name)) :mtime (parse-integer mtime)
:name name))
finally (return out))) finally (return out)))
(declaim (ftype (function ((or string pathname)) hash-table) (declaim (ftype (function ((or string pathname)) hash-table)
@ -86,6 +87,12 @@ part of STRING."
do (with-slots (size mtime) entry do (with-slots (size mtime) entry
(format stream "~A ~A ~A~%" size mtime (url-encode name))))) (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) (defmacro with-atomic-write ((stream path) &body body)
"Evaluate BODY with STREAM bound to a stream that will write to a temporary "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 file. If execution is successful, rename this temporary file to PATH, replacing
@ -94,7 +101,7 @@ it."
(target-path (gensym "TARGET-PATH-")) (target-path (gensym "TARGET-PATH-"))
(dir (gensym "DIR"))) (dir (gensym "DIR")))
`(let* ((,target-path (ensure-nonwild-pathname ,path)) `(let* ((,target-path (ensure-nonwild-pathname ,path))
(,dir (uiop:pathname-parent-directory-pathname ,target-path))) (,dir (parent-directory ,target-path)))
(uiop:call-with-temporary-file (uiop:call-with-temporary-file
#'(lambda (,stream ,tmp-path) #'(lambda (,stream ,tmp-path)
,@body ,@body
@ -150,6 +157,9 @@ directory and the file size cache is out of date, update it."
did-change (not (eql size orig-size)) did-change (not (eql size orig-size))
ret-size size)))) ret-size size))))
(when did-change (when did-change
(with-atomic-write (stream directorysizes-path) (handler-case
(format-directorysizes stream directorysizes))) (with-atomic-write (stream directorysizes-path)
(format-directorysizes stream directorysizes))
;; ignore errors when updating the cache
(osicat-posix:posix-error ())))
ret-size)) ret-size))

4
cl-xdg-trash/mountpoints.lisp
View File

@ -131,3 +131,7 @@ determined, return nil."
;; we have reached the root ;; we have reached the root
do (return cur) do (return cur)
finally (return (or prev bottom)))))))) finally (return (or prev bottom))))))))
(defun same-device-p (path1 path2)
"Return non-nil if PATH1 and PATH2 are on the same device."
(uiop:pathname-equal (find-filesystem-root path1) (find-filesystem-root path2)))

3
cl-xdg-trash/package.lisp
View File

@ -15,7 +15,8 @@
#:find-filesystem-root #:find-filesystem-root
#:ensure-nonwild-pathname #:ensure-nonwild-pathname
#:remove-suffix #:remove-suffix
#:file-or-dir-namestring)) #:file-or-dir-namestring
#:same-device-p))
(defpackage :cl-xdg-trash/trashinfo (defpackage :cl-xdg-trash/trashinfo
(:documentation (:documentation

227
cl-xdg-trash/trash.lisp
View File

@ -1,5 +1,39 @@
(in-package :cl-xdg-trash) (in-package :cl-xdg-trash)
(define-condition trash-error (error)
((trash-directory :accessor trash-error-trash-directory
:type (or pathname string)
:initarg :trash-directory
:documentation "The trash directory of the operation."))
(:report (lambda (condition stream)
(format stream "Error operating on trash directory: ~S"
(uiop:native-namestring (trash-error-trash-directory
condition)))))
(:documentation "A general error that arose when trashing files."))
(define-condition cross-device-error (trash-error)
((source :accessor cross-device-error-source
:type (or pathname string)
:initarg :source
:documentation "The file being moved by the operation.")
(target :accessor cross-device-error-target
:type (or pathname string)
:initarg :target
:documentation "The destination of the move operation."))
(:report (lambda (condition stream)
(with-slots (source target) condition
(format stream "~S and ~S lie on different devices"
(uiop:native-namestring source)
(uiop:native-namestring target)))))
(:documentation "An error that arose when moving files across devices."))
(define-condition file-exists-error (file-error)
()
(:report (lambda (condition stream)
(format stream "File exists: ~S"
(uiop:native-namestring (file-error-pathname condition)))))
(:documentation "An error representing the case that a file already exists."))
(declaim (ftype (function (&key (:homedir (or pathname string null))) pathname) (declaim (ftype (function (&key (:homedir (or pathname string null))) pathname)
xdg-data-home)) xdg-data-home))
(defun xdg-data-home (&key homedir) (defun xdg-data-home (&key homedir)
@ -33,44 +67,41 @@
(defun valid-toplevel-trash-dir-p (path) (defun valid-toplevel-trash-dir-p (path)
"Return non-nil if PATH is a valid toplevel trash directory. That is, it "Return non-nil if PATH is a valid toplevel trash directory. That is, it
exists, is a directory, and: (1) is owned by the current user, (2) has the exists, is a directory, and: (1) is owned by the current user, (2) has the
sticky bit set." sticky bit set (and the info/ and files/ subdirectories are the same)."
(flet ((check-dir (path) (flet ((check-dir (path)
(handler-case (handler-case
(let* ((path (ensure-nonwild-pathname path)) (let* ((path (ensure-nonwild-pathname path))
(stat (osicat-posix:stat path))) (stat (osicat-posix:stat path)))
(and (osicat-posix:s-isdir (osicat-posix:stat-mode stat)) (and (osicat-posix:s-isdir (osicat-posix:stat-mode stat))
(or (sticky-bit-set-p (osicat-posix:stat-mode stat)) (sticky-bit-set-p (osicat-posix:stat-mode stat))
;; has to come second as this will throw if it fails (osicat-posix:access path (logior osicat-posix:r-ok
(osicat-posix:access path (logior osicat-posix:r-ok osicat-posix:w-ok))))
osicat-posix:w-ok)))))
(osicat-posix:posix-error () nil)))) (osicat-posix:posix-error () nil))))
(let* ((path (ensure-nonwild-pathname path :ensure-directory t)) (let* ((path (ensure-nonwild-pathname path :ensure-directory t)))
(dir-sizes-path (calculate-directorysizes-path path))) (and (check-dir path)
(and (uiop:directory-exists-p path)
(check-dir (merge-pathnames "info" path)) (check-dir (merge-pathnames "info" path))
(check-dir (merge-pathnames "files" path)) (check-dir (merge-pathnames "files" path))))))
(if (not (uiop:file-exists-p dir-sizes-path))
(check-dir path)
(handler-case (osicat-posix:access dir-sizes-path
(logior osicat-posix:r-ok
osicat-posix:w-ok))
(osicat-posix:posix-error () nil)))))))
(declaim (ftype (function ((or string pathname)) list) find-trash-dirs-for-toplevel)) (declaim (ftype (function ((or string pathname)) list) find-trash-dirs-for-toplevel))
(defun find-trash-dirs-for-toplevel (toplevel) (defun find-trash-dirs-for-toplevel (toplevel)
"List the trash directories that exist under TOPLEVEL." "List the trash directories that exist under TOPLEVEL."
(let ((top-path (ensure-nonwild-pathname toplevel :ensure-directory t)) (let ((top-path (ensure-nonwild-pathname toplevel :ensure-directory t))
found) found)
(let ((dir (merge-pathnames #P".Trash" top-path))) (let ((dir (merge-pathnames #P".Trash/" top-path)))
(when (valid-toplevel-trash-dir-p dir) (when (valid-toplevel-trash-dir-p dir)
(push dir found))) (push dir found)))
(let ((uid (osicat-posix:getuid))) (let ((uid (osicat-posix:getuid)))
(when uid (when uid
(let ((dir (merge-pathnames (pathname (format nil ".Trash-~D" uid)) (let* ((dir (merge-pathnames (pathname (format nil ".Trash-~D/" uid))
top-path))) top-path))
(when (valid-toplevel-trash-dir-p dir) (stat (handler-case
(osicat-posix:stat (uiop:native-namestring dir))
(osicat-posix:posix-error () nil))))
(when (and stat
(osicat-posix:s-isdir (osicat-posix:stat-mode stat))
(eql (osicat-posix:stat-uid stat) uid))
(push dir found))))) (push dir found)))))
found)) (nreverse found)))
(declaim (ftype (function () list) list-toplevel-trash-directories)) (declaim (ftype (function () list) list-toplevel-trash-directories))
(defun list-toplevel-trash-directories () (defun list-toplevel-trash-directories ()
@ -92,34 +123,100 @@ directory)."
(or (and include-self (uiop:pathname-equal path home)) (or (and include-self (uiop:pathname-equal path home))
(uiop:subpathp path home)))) (uiop:subpathp path home))))
(declaim (ftype (function ((or pathname string)) pathname) (declaim (ftype (function ((or pathname string) &optional list) pathname)
trash-directory-for-file)) trash-directory-for-file))
(defun trash-directory-for-file (path) (defun trash-directory-for-file (path &optional ignored-trash-dirs)
"Return the trash directory into which PATH should be trashed." "Return the trash directory into which PATH should be trashed."
(let* ((res-path (ensure-nonwild-pathname path)) (let* ((res-path (ensure-nonwild-pathname path))
(root (find-filesystem-root res-path))) (root (find-filesystem-root res-path)))
(or (and (path-in-home-directory-p res-path) (or (and (path-in-home-directory-p res-path)
(uiop:pathname-equal (find-filesystem-root (user-homedir-pathname)) (uiop:pathname-equal (find-filesystem-root (user-homedir-pathname))
root) root)
(car (find-trash-dirs-for-toplevel root))) (user-home-trash-directory))
(user-home-trash-directory)))) (or (car (set-difference (find-trash-dirs-for-toplevel root)
ignored-trash-dirs
:test #'uiop:pathname-equal))
(user-home-trash-directory)))))
(declaim (ftype (function ((or pathname string) &optional t) t) trash-file)) (defun rename-safely (source target)
(defun trash-file (path &optional (update-size-cache t)) "Move SOURCE to TARGET, signaling an error if TARGET already exists."
(let ((source (ensure-nonwild-pathname source))
(target (ensure-nonwild-pathname target)))
;; without specific OS and file-system support, it's impossible to do theses
;; two operations atomically, so we settle for this
(when (probe-file target)
(error 'file-exists-error :pathname target))
(osicat-posix:rename (uiop:native-namestring source)
(uiop:native-namestring target))))
(declaim (ftype (function ((or pathname string) (or pathname string)) t)
copy-file))
(defun copy-file (source target)
"Copy the normal file SOURCE to TARGET. Error if TARGET already exists."
(with-open-file (in (ensure-nonwild-pathname source)
:direction :input
:if-does-not-exist :error)
(with-open-file (out (ensure-nonwild-pathname target)
:direction :output
:if-exists :error)
(uiop:copy-stream-to-stream in out))))
(declaim (ftype (function ((or string pathname)
(or string pathname)
&key (:no-cross-device t))
t)
move-or-copy-files))
(defun move-or-copy-files (source target &key no-cross-device)
"Either or move or copy SOURCE to TARGET. Copy SOURCE if it is a regular file
and SOURCE and TARGET lie on different devices. With NO-CROSS-DEVICE, don't
ever copy and instead signal an error. Always error if SOURCE is a directory and
SOURCE and TARGET lie on different devices."
(let ((source (ensure-nonwild-pathname source))
(target (ensure-nonwild-pathname target)))
(handler-case
(rename-safely source target)
(osicat-posix:exdev ()
(if (or no-cross-device
(uiop:directory-exists-p source))
(error 'cross-device-error :source source
:target target)
(progn
(copy-file source target)
(delete-file source)))))))
(declaim (ftype (function ((or pathname string)
&key
(:no-cross-device t)
(:ignored-trash-dirs list)
(:update-size-cache t)
(:trash-directory (or null string pathname)))
t)
trash-file))
(defun trash-file (path &key no-cross-device ignored-trash-dirs
(update-size-cache t) trash-directory)
"Move PATH to the trash. Specifically, move it to the proper trash as "Move PATH to the trash. Specifically, move it to the proper trash as
specified by the XDG standard. If UPDATE-SIZE-CACHE is non-nil (the default) specified by the XDG standard. If UPDATE-SIZE-CACHE is non-nil (the default)
also update the directory size cache." also update the directory size cache. If NO-CROSS-DEVICE is non-nil, don't trash
files to directories on other devices. Also, don't move files to trash
directories in IGNORED-TRASH-DIRS. With TRASH-DIRECTORY, force trashing to a
specific directory."
(let* ((path (merge-pathnames (ensure-nonwild-pathname path) (uiop:getcwd))) (let* ((path (merge-pathnames (ensure-nonwild-pathname path) (uiop:getcwd)))
(trash-directory (trash-directory-for-file path)) (trash-directory (if trash-directory
(trashinfo (make-trashinfo-for trash-directory path)) (ensure-nonwild-pathname trash-directory
:ensure-directory t)
(trash-directory-for-file path ignored-trash-dirs)))
(files-dir (ensure-directories-exist (merge-pathnames (files-dir (ensure-directories-exist (merge-pathnames
#P"files/" trash-directory) #P"files/" trash-directory)
:verbose nil))) :verbose nil))
(osicat-posix:rename (uiop:native-namestring path) (trashinfo (make-trashinfo-for trash-directory path))
(uiop:native-namestring (target (merge-pathnames (make-pathname
(merge-pathnames :name (trashinfo-name trashinfo))
(make-pathname :name (trashinfo-name trashinfo)) files-dir)))
files-dir))) (handler-bind
((t (lambda (e)
(declare (ignore e))
(delete-file (trashinfo-info-file trashinfo)))))
(move-or-copy-files path target :no-cross-device no-cross-device))
(when update-size-cache (when update-size-cache
(trashed-file-size trash-directory (trashinfo-name trashinfo))))) (trashed-file-size trash-directory (trashinfo-name trashinfo)))))
@ -142,10 +239,12 @@ TRASH-DIRECTORY."
(mapcan #'(lambda (path) (mapcan #'(lambda (path)
(let ((name (file-or-dir-namestring path))) (let ((name (file-or-dir-namestring path)))
(when (uiop:string-suffix-p name ".trashinfo") (when (uiop:string-suffix-p name ".trashinfo")
(list (parse-trashinfo-file (handler-case
trash-directory (list (parse-trashinfo-file
(subseq name 0 (- (length name) trash-directory
(length ".trashinfo")))))))) (subseq name 0 (- (length name)
(length ".trashinfo")))))
(trashinfo-format-error () nil)))))
(uiop:directory-files info-dir)))) (uiop:directory-files info-dir))))
(declaim (ftype (function (&optional (or pathname string list)) list) (declaim (ftype (function (&optional (or pathname string list)) list)
@ -156,29 +255,30 @@ TRASH-DIRECTORIES. TRASH-DIRECTORIES can also be a single path."
(mapcan #'list-trashed-files-for-directory (mapcan #'list-trashed-files-for-directory
(normalize-trash-directories trash-directories))) (normalize-trash-directories trash-directories)))
(declaim (ftype (function (trashinfo &optional (or string pathname) t) t) (declaim (ftype (function (trashinfo &key (:target (or string pathname))
(:update-size-cache t)
(:no-cross-device t))
t)
restore-file)) restore-file))
(defun restore-file (trashinfo &optional (defun restore-file (trashinfo &key
(target (trashinfo-original-path (target (trashinfo-original-path trashinfo))
trashinfo)) (update-size-cache t)
(update-size-cache t)) no-cross-device)
"Restore the file pointed to by TRASHINFO. If UPDATE-SIZE-CACHE is non-nil "Restore the file pointed to by TRASHINFO. If UPDATE-SIZE-CACHE is non-nil
(the default), also update the directory size cache." (the default), also update the directory size cache."
(let ((target (ensure-nonwild-pathname target))) (let ((source (trashinfo-trashed-file trashinfo))
(osicat-posix:rename (target (ensure-nonwild-pathname target)))
(uiop:native-namestring (trashinfo-trashed-file trashinfo)) (move-or-copy-files source target :no-cross-device no-cross-device)
(uiop:native-namestring target))) (handler-bind
(handler-bind ;; attempt to re-trash the file in case of error
;; attempt to re-trash the file in case of error ((t #'(lambda (e)
((t #'(lambda (e) (move-or-copy-files target source
(osicat-posix:rename :no-cross-device no-cross-device)
(uiop:native-namestring target) (signal e))))
(uiop:native-namestring (trashinfo-trashed-file trashinfo))) (delete-file (trashinfo-info-file trashinfo))
(signal e)))) (when update-size-cache
(delete-file (trashinfo-info-file trashinfo)) (trashed-file-size (trashinfo-trash-directory trashinfo)
(when update-size-cache (trashinfo-name trashinfo))))))
(trashed-file-size (trashinfo-trash-directory trashinfo)
(trashinfo-name trashinfo)))))
(declaim (ftype (function (trashinfo &key (:dry-run t)) t) empty-file)) (declaim (ftype (function (trashinfo &key (:dry-run t)) t) empty-file))
(defun empty-file (trashinfo &key (dry-run t)) (defun empty-file (trashinfo &key (dry-run t))
@ -193,9 +293,12 @@ DRY-RUN, don't actually delete anything."
(handler-case (handler-case
(progn (progn
(delete-file info-file) (delete-file info-file)
(uiop:delete-directory-tree trashed-file (if (uiop:directory-exists-p trashed-file)
:validate t (uiop:delete-directory-tree
:if-does-not-exist :ignore) (uiop:ensure-directory-pathname trashed-file)
:validate t
:if-does-not-exist :ignore)
(delete-file trashed-file))
(trashed-file-size trash-directory name)))))) (trashed-file-size trash-directory name))))))
(declaim (ftype (function ((or string pathname)) list) directory-files)) (declaim (ftype (function ((or string pathname)) list) directory-files))

468
clash/clash.lisp
View File

@ -8,7 +8,10 @@
#:trashinfo-trashed-file #:trashinfo-trashed-file
#:trashinfo-deletion-date) #:trashinfo-deletion-date)
(:import-from #:cl-xdg-trash/mountpoints (: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) (:use #:cl)
(:export #:toplevel)) (:export #:toplevel))
@ -20,6 +23,212 @@
(call-next-method command str-stream)))) (call-next-method command str-stream))))
(format stream "~A" (subseq msg 0 (1- (length msg)))))) (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 ;; Filtering
(defun clingon-filtering-options () (defun clingon-filtering-options ()
@ -65,7 +274,13 @@
:key :format :key :format
:description "format to print results in" :description "format to print results in"
:short-name #\f :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)) (declaim (inline compare-trashinfo-to-string))
(defun compare-trashinfo-to-string (trashinfo filter full-path exact (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." "Compare TRASHINFO's name or path to FILTER, which is a cl-ppcre scanner."
(let* ((orig-path (trashinfo-original-path trashinfo)) (let* ((orig-path (trashinfo-original-path trashinfo))
(target (if full-path orig-path (file-or-dir-namestring orig-path)))) (target (if full-path orig-path (file-or-dir-namestring orig-path))))
(destructuring-bind (start &optional end &rest ignore) (multiple-value-bind (start end) (cl-ppcre:scan filter target)
(multiple-value-list (cl-ppcre:scan filter target))
(declare (ignore ignore))
(and start (and start
(or (not exact) (or (not exact)
(and (= start 0) (= end (length target)))))))) (and (= start 0) (= end (length target))))))))
@ -116,65 +329,85 @@ string."
(defun list-nonexcluded-trash-dirs (cmd) (defun list-nonexcluded-trash-dirs (cmd)
"Return a list of all trash directories, except those excluded by CMD." "Return a list of all trash directories, except those excluded by CMD."
(set-difference (cl-xdg-trash:list-trash-directories) (append (set-difference (cl-xdg-trash:list-trash-directories)
(clingon:getopt cmd :ignored-trashes) (clingon:getopt cmd :ignored-trashes)
:test #'uiop:pathname-equal)) :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) (defun list-trashinfos-for-cmd (cmd)
"List trashinfos for the command CMD." "List trashinfos for the command CMD."
(let ((args (clingon:command-arguments cmd))) (let ((args (clingon:command-arguments cmd)))
(when (cdr args) (when (cdr args)
(clingon:print-usage-and-exit cmd t)) (clingon:print-usage-and-exit cmd t))
(if (not (car args)) (limit-trashinfo-dates-for-cmd
(cl-xdg-trash:list-trashed-files (list-nonexcluded-trash-dirs cmd)) cmd
(let ((filter (car args)) (if (not (car args))
(strings (clingon:getopt cmd :strings)) (cl-xdg-trash:list-trashed-files (list-nonexcluded-trash-dirs cmd))
(exact (clingon:getopt cmd :exact)) (let ((filter (car args))
(full-path (clingon:getopt cmd :full-path)) (strings (clingon:getopt cmd :strings))
(case-insensitive (clingon:getopt cmd :case-insensitive)) (exact (clingon:getopt cmd :exact))
(invert (clingon:getopt cmd :invert))) (full-path (clingon:getopt cmd :full-path))
(filter-trashinfos-by (case-insensitive (clingon:getopt cmd :case-insensitive))
(cl-xdg-trash:list-trashed-files (invert (clingon:getopt cmd :invert)))
(list-nonexcluded-trash-dirs cmd)) (filter-trashinfos-by
filter (cl-xdg-trash:list-trashed-files
:regexp (not strings) (list-nonexcluded-trash-dirs cmd))
:exact exact filter
:full-path full-path :regexp (not strings)
:case-insensitive case-insensitive :exact exact
:invert invert))))) :full-path full-path
:case-insensitive case-insensitive
:invert invert))))))
;; Formatting ;; Formatting
(defparameter *trashinfo-formatters* (defparameter *trashinfo-formatters*
`((#\o . ,(lambda (stream info) `((#\# :index
"the (o)riginal path" "the index of the current file (used when prompting for files)")
(format stream "~A" (trashinfo-original-path info)))) (#\o ,(lambda (stream info)
(#\n . ,(lambda (stream info) (format stream "~A" (trashinfo-original-path info)))
"the original (n)ame" "the (o)riginal path")
(format stream "~A" (file-or-dir-namestring (#\n ,(lambda (stream info)
(trashinfo-original-path info))))) (format stream "~A" (file-or-dir-namestring
(#\d . ,(lambda (stream info) (trashinfo-original-path info))))
"the trash (d)irectory" "the original (n)ame")
(format stream "~A" (trashinfo-trash-directory info)))) (#\d ,(lambda (stream info)
(#\i . ,(lambda (stream info) (format stream "~A" (trashinfo-trash-directory info)))
"the trash(i)nfo file path" "the trash (d)irectory")
(format stream "~A" (trashinfo-info-file info)))) (#\i ,(lambda (stream info)
(#\c . ,(lambda (stream info) (format stream "~A" (trashinfo-info-file info)))
"the (c)urrent (trashed) path" "the trash(i)nfo file path")
(format stream "~A" (trashinfo-trashed-file info)))) (#\c ,(lambda (stream info)
(#\u . ,(lambda (stream info) (format stream "~A" (trashinfo-trashed-file info)))
"the time the file was trashed (in (u)TC seconds)" "the (c)urrent (trashed) path")
(format stream "~A" (local-time:timestamp-to-unix (#\u ,(lambda (stream info)
(trashinfo-deletion-date info))))) (format stream "~A" (local-time:timestamp-to-unix
(#\t . ,(lambda (stream info) (trashinfo-deletion-date info))))
"the (t)ime the file was trashed (pretty-printed local time)" "the time the file was trashed (in (u)TC seconds)")
(local-time:format-timestring (#\t ,(lambda (stream info)
stream (trashinfo-deletion-date info) (local-time:format-timestring
:format local-time:+asctime-format+))) stream (trashinfo-deletion-date info)
(#\% . ,(lambda (stream info) :format local-time:+asctime-format+))
"a liternal %" "the (t)ime the file was trashed (pretty-printed local time)")
(declare (ignore info)) (#\t ,(lambda (stream info)
(format stream "%"))))) (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) (defun process-format-string (format-string)
"Process FORMAT-STRING into a list of string and functions." "Process FORMAT-STRING into a list of string and functions."
@ -202,9 +435,9 @@ string."
(#\% (#\%
(ensure-next-char i "substitution") (ensure-next-char i "substitution")
(push-string (subseq format-string start i)) (push-string (subseq format-string start i))
(let ((fun (cdr (assoc (aref format-string (1+ i)) (let ((fun (second (assoc (aref format-string (1+ i))
*trashinfo-formatters*)))) *trashinfo-formatters*))))
(unless (functionp fun) (unless fun
(unknown i "substitution")) (unknown i "substitution"))
(push-thing fun)) (push-thing fun))
(setq start (+ i 2) (setq start (+ i 2)
@ -224,13 +457,16 @@ string."
(push-string (subseq format-string start)) (push-string (subseq format-string start))
out))) 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 "Format the trashinfo INFO to STREAM accoring to FORMAT-OBJECT (which is from
process-format-string)." process-format-string)."
(dolist (part format-object) (dolist (part format-object)
(if (stringp part) (cond
(format stream "~A" part) ((eq :index part)
(funcall part stream info)))) (format stream "~A" index))
((stringp part)
(format stream "~A" part))
(t (funcall part stream info)))))
(defun print-format-info (&optional (stream t)) (defun print-format-info (&optional (stream t))
(format stream "~ (format stream "~
@ -243,8 +479,8 @@ output verbatim. The recognized C-style escapes sequences are:
\"\\\\\" - literal backslash \"\\\\\" - literal backslash
The recognizes printf-style sequences are (parenthesis denote the mnemonic):~%") The recognizes printf-style sequences are (parenthesis denote the mnemonic):~%")
(dolist (entry *trashinfo-formatters*) (dolist (entry *trashinfo-formatters*)
(let ((char (car entry)) (let ((char (first entry))
(doc (documentation (cdr entry) t))) (doc (third entry)))
(format stream " \"%~A\" - ~A~%" char doc)))) (format stream " \"%~A\" - ~A~%" char doc))))
@ -289,30 +525,121 @@ The recognizes printf-style sequences are (parenthesis denote the mnemonic):~%")
;; List command ;; List command
(defun list/handler (cmd) (defun list/handler (cmd)
"Toplevel for the \"list\" subcommand." "Handler for the \"list\" subcommand."
(if (clingon:getopt cmd :print-format-info) (if (clingon:getopt cmd :print-format-info)
(print-format-info t) (print-format-info t)
(let ((format (process-format-string (or (clingon:getopt cmd :format) (let ((format (process-format-string (or (clingon:getopt cmd :format)
"%t %o\\n")))) "%t %o\\n"))))
(dolist (info (sort-trashinfos-for-cmd (loop for info in (sort-trashinfos-for-cmd
(list-trashinfos-for-cmd cmd) cmd)) (list-trashinfos-for-cmd cmd) cmd)
(format-trashinfo t format info))))) for i upfrom 1
do (format-trashinfo t format info :index i)))))
(defun list/options () (defun list/options ()
"Return options for the \"list\" subcommand." "Return options for the \"list\" subcommand."
(append (append
(clingon-filtering-options) (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 () (defun list/command ()
"Return the Clingon command for the \"list\" subcommand." "Return the Clingon command for the \"list\" subcommand."
(clingon:make-command (clingon:make-command
:name "list" :name "list"
:description "list files in trash directories" :description "list files in trash directories"
:usage "[pattern]" :usage "[options] [pattern]"
:options (list/options) :options (list/options)
:handler #'list/handler)) :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 ;; Toplevel command
(defun toplevel/options () (defun toplevel/options ()
@ -334,7 +661,8 @@ The recognizes printf-style sequences are (parenthesis denote the mnemonic):~%")
:license "GPL3" :license "GPL3"
:authors '("Alexander Rosenberg <zanderpkg@pm.me>") :authors '("Alexander Rosenberg <zanderpkg@pm.me>")
:options (toplevel/options) :options (toplevel/options)
:sub-commands (list (list/command)) :sub-commands (list (list/command)
(put/command))
:handler #'(lambda (cmd) :handler #'(lambda (cmd)
(clingon:print-usage-and-exit cmd t)))) (clingon:print-usage-and-exit cmd t))))