From b8344096842600996feec126e2dbec1124b9b248 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Thu, 23 Oct 2025 20:04:32 -0700 Subject: [PATCH] Fix some bugs and add date-based filtering --- cl-xdg-trash/directorysizes.lisp | 26 +- cl-xdg-trash/mountpoints.lisp | 4 + cl-xdg-trash/package.lisp | 3 +- cl-xdg-trash/trash.lisp | 227 +++++++++++---- clash/clash.lisp | 468 ++++++++++++++++++++++++++----- 5 files changed, 587 insertions(+), 141 deletions(-) diff --git a/cl-xdg-trash/directorysizes.lisp b/cl-xdg-trash/directorysizes.lisp index 1e6989c..ce307cb 100644 --- a/cl-xdg-trash/directorysizes.lisp +++ b/cl-xdg-trash/directorysizes.lisp @@ -55,11 +55,12 @@ part of STRING." while line for (size mtime encoded-name) = (split-string line #\Space 3) for name = (url-decode encoded-name) - do (setf (gethash name out) - (make-directorysizes-entry - :size (parse-integer size) - :mtime (parse-integer mtime) - :name name)) + when (and size mtime encoded-name) + do (setf (gethash name out) + (make-directorysizes-entry + :size (parse-integer size) + :mtime (parse-integer mtime) + :name name)) finally (return out))) (declaim (ftype (function ((or string pathname)) hash-table) @@ -86,6 +87,12 @@ 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 @@ -94,7 +101,7 @@ it." (target-path (gensym "TARGET-PATH-")) (dir (gensym "DIR"))) `(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 #'(lambda (,stream ,tmp-path) ,@body @@ -150,6 +157,9 @@ directory and the file size cache is out of date, update it." did-change (not (eql size orig-size)) ret-size size)))) (when did-change - (with-atomic-write (stream directorysizes-path) - (format-directorysizes stream directorysizes))) + (handler-case + (with-atomic-write (stream directorysizes-path) + (format-directorysizes stream directorysizes)) + ;; ignore errors when updating the cache + (osicat-posix:posix-error ()))) ret-size)) diff --git a/cl-xdg-trash/mountpoints.lisp b/cl-xdg-trash/mountpoints.lisp index 53e7904..6ae57d2 100644 --- a/cl-xdg-trash/mountpoints.lisp +++ b/cl-xdg-trash/mountpoints.lisp @@ -131,3 +131,7 @@ determined, return nil." ;; we have reached the root do (return cur) 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))) diff --git a/cl-xdg-trash/package.lisp b/cl-xdg-trash/package.lisp index b5c81fa..be41e02 100644 --- a/cl-xdg-trash/package.lisp +++ b/cl-xdg-trash/package.lisp @@ -15,7 +15,8 @@ #:find-filesystem-root #:ensure-nonwild-pathname #:remove-suffix - #:file-or-dir-namestring)) + #:file-or-dir-namestring + #:same-device-p)) (defpackage :cl-xdg-trash/trashinfo (:documentation diff --git a/cl-xdg-trash/trash.lisp b/cl-xdg-trash/trash.lisp index 68b5b7f..eec0108 100644 --- a/cl-xdg-trash/trash.lisp +++ b/cl-xdg-trash/trash.lisp @@ -1,5 +1,39 @@ (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) xdg-data-home)) (defun xdg-data-home (&key homedir) @@ -33,44 +67,41 @@ (defun valid-toplevel-trash-dir-p (path) "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 -sticky bit set." +sticky bit set (and the info/ and files/ subdirectories are the same)." (flet ((check-dir (path) (handler-case (let* ((path (ensure-nonwild-pathname path)) (stat (osicat-posix:stat path))) (and (osicat-posix:s-isdir (osicat-posix:stat-mode stat)) - (or (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:w-ok))))) + (sticky-bit-set-p (osicat-posix:stat-mode stat)) + (osicat-posix:access path (logior osicat-posix:r-ok + osicat-posix:w-ok)))) (osicat-posix:posix-error () nil)))) - (let* ((path (ensure-nonwild-pathname path :ensure-directory t)) - (dir-sizes-path (calculate-directorysizes-path path))) - (and (uiop:directory-exists-p path) + (let* ((path (ensure-nonwild-pathname path :ensure-directory t))) + (and (check-dir path) (check-dir (merge-pathnames "info" 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))))))) + (check-dir (merge-pathnames "files" path)))))) (declaim (ftype (function ((or string pathname)) list) find-trash-dirs-for-toplevel)) (defun find-trash-dirs-for-toplevel (toplevel) "List the trash directories that exist under TOPLEVEL." (let ((top-path (ensure-nonwild-pathname toplevel :ensure-directory t)) found) - (let ((dir (merge-pathnames #P".Trash" top-path))) + (let ((dir (merge-pathnames #P".Trash/" top-path))) (when (valid-toplevel-trash-dir-p dir) (push dir found))) (let ((uid (osicat-posix:getuid))) (when uid - (let ((dir (merge-pathnames (pathname (format nil ".Trash-~D" uid)) - top-path))) - (when (valid-toplevel-trash-dir-p dir) + (let* ((dir (merge-pathnames (pathname (format nil ".Trash-~D/" uid)) + top-path)) + (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))))) - found)) + (nreverse found))) (declaim (ftype (function () list) list-toplevel-trash-directories)) (defun list-toplevel-trash-directories () @@ -92,34 +123,100 @@ directory)." (or (and include-self (uiop:pathname-equal 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)) -(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." (let* ((res-path (ensure-nonwild-pathname path)) (root (find-filesystem-root res-path))) (or (and (path-in-home-directory-p res-path) (uiop:pathname-equal (find-filesystem-root (user-homedir-pathname)) 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 trash-file (path &optional (update-size-cache t)) +(defun rename-safely (source target) + "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 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))) - (trash-directory (trash-directory-for-file path)) - (trashinfo (make-trashinfo-for trash-directory path)) + (trash-directory (if trash-directory + (ensure-nonwild-pathname trash-directory + :ensure-directory t) + (trash-directory-for-file path ignored-trash-dirs))) (files-dir (ensure-directories-exist (merge-pathnames #P"files/" trash-directory) - :verbose nil))) - (osicat-posix:rename (uiop:native-namestring path) - (uiop:native-namestring - (merge-pathnames - (make-pathname :name (trashinfo-name trashinfo)) - files-dir))) + :verbose nil)) + (trashinfo (make-trashinfo-for trash-directory path)) + (target (merge-pathnames (make-pathname + :name (trashinfo-name trashinfo)) + 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 (trashed-file-size trash-directory (trashinfo-name trashinfo))))) @@ -142,10 +239,12 @@ TRASH-DIRECTORY." (mapcan #'(lambda (path) (let ((name (file-or-dir-namestring path))) (when (uiop:string-suffix-p name ".trashinfo") - (list (parse-trashinfo-file - trash-directory - (subseq name 0 (- (length name) - (length ".trashinfo")))))))) + (handler-case + (list (parse-trashinfo-file + trash-directory + (subseq name 0 (- (length name) + (length ".trashinfo"))))) + (trashinfo-format-error () nil))))) (uiop:directory-files info-dir)))) (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 (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)) -(defun restore-file (trashinfo &optional - (target (trashinfo-original-path - trashinfo)) - (update-size-cache t)) +(defun restore-file (trashinfo &key + (target (trashinfo-original-path trashinfo)) + (update-size-cache t) + no-cross-device) "Restore the file pointed to by TRASHINFO. If UPDATE-SIZE-CACHE is non-nil (the default), also update the directory size cache." - (let ((target (ensure-nonwild-pathname target))) - (osicat-posix:rename - (uiop:native-namestring (trashinfo-trashed-file trashinfo)) - (uiop:native-namestring target))) - (handler-bind - ;; attempt to re-trash the file in case of error - ((t #'(lambda (e) - (osicat-posix:rename - (uiop:native-namestring target) - (uiop:native-namestring (trashinfo-trashed-file trashinfo))) - (signal e)))) - (delete-file (trashinfo-info-file trashinfo)) - (when update-size-cache - (trashed-file-size (trashinfo-trash-directory trashinfo) - (trashinfo-name trashinfo))))) + (let ((source (trashinfo-trashed-file trashinfo)) + (target (ensure-nonwild-pathname target))) + (move-or-copy-files source target :no-cross-device no-cross-device) + (handler-bind + ;; attempt to re-trash the file in case of error + ((t #'(lambda (e) + (move-or-copy-files target source + :no-cross-device no-cross-device) + (signal e)))) + (delete-file (trashinfo-info-file trashinfo)) + (when update-size-cache + (trashed-file-size (trashinfo-trash-directory trashinfo) + (trashinfo-name trashinfo)))))) (declaim (ftype (function (trashinfo &key (:dry-run t)) t) empty-file)) (defun empty-file (trashinfo &key (dry-run t)) @@ -193,9 +293,12 @@ DRY-RUN, don't actually delete anything." (handler-case (progn (delete-file info-file) - (uiop:delete-directory-tree trashed-file - :validate t - :if-does-not-exist :ignore) + (if (uiop:directory-exists-p trashed-file) + (uiop:delete-directory-tree + (uiop:ensure-directory-pathname trashed-file) + :validate t + :if-does-not-exist :ignore) + (delete-file trashed-file)) (trashed-file-size trash-directory name)))))) (declaim (ftype (function ((or string pathname)) list) directory-files)) diff --git a/clash/clash.lisp b/clash/clash.lisp index a9205c3..2ccddb6 100644 --- a/clash/clash.lisp +++ b/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 ") :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))))