Fix some bugs and add date-based filtering
This commit is contained in:
@ -55,6 +55,7 @@ part of STRING."
|
||||
while line
|
||||
for (size mtime encoded-name) = (split-string line #\Space 3)
|
||||
for name = (url-decode encoded-name)
|
||||
when (and size mtime encoded-name)
|
||||
do (setf (gethash name out)
|
||||
(make-directorysizes-entry
|
||||
:size (parse-integer size)
|
||||
@ -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
|
||||
(handler-case
|
||||
(with-atomic-write (stream directorysizes-path)
|
||||
(format-directorysizes stream directorysizes)))
|
||||
(format-directorysizes stream directorysizes))
|
||||
;; ignore errors when updating the cache
|
||||
(osicat-posix:posix-error ())))
|
||||
ret-size))
|
||||
|
||||
@ -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)))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
(sticky-bit-set-p (osicat-posix:stat-mode stat))
|
||||
(osicat-posix:access path (logior osicat-posix:r-ok
|
||||
osicat-posix:w-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))
|
||||
: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")
|
||||
(handler-case
|
||||
(list (parse-trashinfo-file
|
||||
trash-directory
|
||||
(subseq name 0 (- (length name)
|
||||
(length ".trashinfo"))))))))
|
||||
(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)))
|
||||
(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)
|
||||
(osicat-posix:rename
|
||||
(uiop:native-namestring target)
|
||||
(uiop:native-namestring (trashinfo-trashed-file trashinfo)))
|
||||
(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)))))
|
||||
(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
|
||||
(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))
|
||||
|
||||
422
clash/clash.lisp
422
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,15 +329,28 @@ 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)
|
||||
(append (set-difference (cl-xdg-trash:list-trash-directories)
|
||||
(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)
|
||||
"List trashinfos for the command CMD."
|
||||
(let ((args (clingon:command-arguments cmd)))
|
||||
(when (cdr args)
|
||||
(clingon:print-usage-and-exit cmd t))
|
||||
(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))
|
||||
@ -141,40 +367,47 @@ string."
|
||||
:exact exact
|
||||
:full-path full-path
|
||||
:case-insensitive case-insensitive
|
||||
:invert invert)))))
|
||||
: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"
|
||||
`((#\# :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)))))
|
||||
(#\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)"
|
||||
(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)))))
|
||||
(#\t . ,(lambda (stream info)
|
||||
"the (t)ime the file was trashed (pretty-printed local time)"
|
||||
(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+)))
|
||||
(#\% . ,(lambda (stream info)
|
||||
"a liternal %"
|
||||
: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 "%")))))
|
||||
(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))
|
||||
(let ((fun (second (assoc (aref format-string (1+ i))
|
||||
*trashinfo-formatters*))))
|
||||
(unless (functionp fun)
|
||||
(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))))
|
||||
|
||||
|
||||
Reference in New Issue
Block a user