diff --git a/README.md b/README.md index 759adf7..e0a3a18 100644 --- a/README.md +++ b/README.md @@ -1,5 +1,7 @@ -# cl-xdg-trash +# cl-xdg-trash (and clash) -`cl-xdg-trash` is a Common Lisp interface to the standard XDG trash -specification. You can find a copy of the specification on the [freedesktop.org -git](https://cgit.freedesktop.org/xdg/xdg-specs/tree/trash). +This repository contains two different (related) projects. The first is +`cl-xdg-trash`, which is a Common Lisp interface to the XDG trash +specification. The second is `clash`, which is a command-line that relies on +`cl-xdg-trash`. Each of them has their own `README.md` file, so check those out +for more information and usage instructions. diff --git a/cl-xdg-trash/README.md b/cl-xdg-trash/README.md new file mode 100644 index 0000000..6111954 --- /dev/null +++ b/cl-xdg-trash/README.md @@ -0,0 +1,25 @@ +# cl-xdg-trash + +`cl-xdg-trash` is a Common Lisp interface to the standard XDG trash +specification. You can find a copy of the specification +[here](https://www.freedesktop.org/wiki/Specifications/trash-spec/). + +## Use +`cl-xdg-trash` depends on `local-time`, `uiop`, `trivial-features`, and +`osicat`. You'll need to obtain them before you try to use `cl-xdg-trash`. + +To use, put this somewhere in your [asdf](https://asdf.common-lisp.dev/) load +path and evaluate: +```lisp +(asdf:load-system :cl-xdg-trash) +``` +You can also use [Quicklisp](https://www.quicklisp.org/beta/) (just for loading, +you still need to download `cl-xdg-trash` manually): +```lisp +(ql:quickload :cl-xdg-trash) +``` +Using `Quicklisp` has the advantage of automatically downloading and building +dependencies. + +To get started, have a look at `trash.lisp` for the main end-user functions. To +find a list of all exported function, see `package.lisp`. diff --git a/cl-xdg-trash/cl-xdg-trash.asd b/cl-xdg-trash/cl-xdg-trash.asd index aa7037d..037b23e 100644 --- a/cl-xdg-trash/cl-xdg-trash.asd +++ b/cl-xdg-trash/cl-xdg-trash.asd @@ -5,7 +5,7 @@ :maintainer "Alexander Rosenberg " :homepage "https://git.zander.im/Zander671/cl-xdg-trash" :license "GPL3" - :depends-on (#:local-time #:uiop #:trivial-features :osicat) + :depends-on (#:local-time #:uiop #:trivial-features #:osicat) :serial t :components ((:file "package") @@ -16,7 +16,7 @@ (:file "trash")) :long-description #.(uiop:read-file-string - (uiop:subpathname *load-pathname* "../README.md"))) + (uiop:subpathname *load-pathname* "README.md"))) (defsystem #:cl-xdg-trash/tests :description "Tests for cl-xdg-trash" diff --git a/cl-xdg-trash/directorysizes.lisp b/cl-xdg-trash/directorysizes.lisp index 3e9bac1..7fcc02b 100644 --- a/cl-xdg-trash/directorysizes.lisp +++ b/cl-xdg-trash/directorysizes.lisp @@ -1,15 +1,5 @@ (in-package :cl-xdg-trash/directorysizes) -(declaim (ftype (function ((or string pathname)) pathname) - directory-as-file-pathname)) -(defun directory-as-file-pathname (path) - "Return PATH as a file, not a directory pathname." - (let ((path (ensure-nonwild-pathname path))) - (if (uiop:file-pathname-p path) - path - (make-pathname :name (file-or-dir-namestring path) :type nil - :directory (butlast (pathname-directory path)))))) - (declaim (ftype (function ((or string pathname) &optional t) integer) file-size)) (defun file-size (path &optional (no-errors t)) "Return the size of the file (inode) named by PATH." @@ -95,12 +85,6 @@ part of STRING." do (with-slots (size mtime) entry (format stream "~A ~A ~A~%" size mtime (url-encode name))))) -(declaim (ftype (function ((or string pathname)) pathname) parent-directory)) -(defun parent-directory (path) - "Return the parent directory of PATH." - (uiop:pathname-parent-directory-pathname - (uiop:ensure-directory-pathname path))) - (defmacro with-atomic-write ((stream path) &body body) "Evaluate BODY with STREAM bound to a stream that will write to a temporary file. If execution is successful, rename this temporary file to PATH, replacing diff --git a/cl-xdg-trash/package.lisp b/cl-xdg-trash/package.lisp index 40e5179..fb7d4c3 100644 --- a/cl-xdg-trash/package.lisp +++ b/cl-xdg-trash/package.lisp @@ -28,8 +28,11 @@ (:import-from #:cl-xdg-trash/mountpoints #:file-or-dir-namestring #:ensure-nonwild-pathname - #:remove-suffix) - (:export #:trashinfo-format-error + #:remove-suffix + #:find-filesystem-root) + (:export #:directory-as-file-pathname + #:parent-directory + #:trashinfo-format-error #:trashinfo-format-error-message #:trashinfo-format-error-line-numer #:trashinfo-format-error-context @@ -58,9 +61,10 @@ #:url-encode #:url-decode) (:import-from #:cl-xdg-trash/trashinfo - #:compute-trashinfo-source-file) - (:export #:directory-as-file-pathname - #:read-directorysizes-file + #:compute-trashinfo-source-file + #:parent-directory + #:directory-as-file-pathname) + (:export #:read-directorysizes-file #:prase-directorysizes #:trashed-file-size #:calculate-directorysizes-path)) @@ -80,4 +84,5 @@ #:list-trashed-files #:restore-file #:empty-file - #:empty-all)) + #:empty-all + #:trash-directory-size)) diff --git a/cl-xdg-trash/trash.lisp b/cl-xdg-trash/trash.lisp index 91f15ae..f01d4c1 100644 --- a/cl-xdg-trash/trash.lisp +++ b/cl-xdg-trash/trash.lisp @@ -183,7 +183,7 @@ ROOT. IGNORED-TRASH-DIRS must be directory paths that are not wild!" ht)))) (if (and (path-in-home-directory-p res-path) (uiop:pathname-equal - (find-filesystem-root (user-homedir-pathname)) root)) + (find-filesystem-root (user-home-trash-directory)) root)) home-trash (or (maybe-create-toplevel-trash-dir root ignored-trash-dirs) home-trash)))) @@ -282,8 +282,8 @@ specific directory." (ensure-nonwild-pathname elt :ensure-directory t)) trash-directories))) -(declaim (ftype (function (pathname) list) list-trashed-files-for-directory)) -(defun list-trashed-files-for-directory (trash-directory) +(declaim (ftype (function (pathname t) list) list-trashed-files-for-directory)) +(defun list-trashed-files-for-directory (trash-directory include-missing) "Return a list of trashinfo objects for every trashed file in TRASH-DIRECTORY." (let ((info-dir (uiop:ensure-directory-pathname @@ -297,18 +297,24 @@ TRASH-DIRECTORY." (subseq name 0 (- (length name) (length ".trashinfo")))))) - (when (probe-file - (trashinfo-trashed-file trashinfo)) + (when (or include-missing + (probe-file + (trashinfo-trashed-file trashinfo))) (list trashinfo))) (trashinfo-format-error ()))))) (uiop:directory-files info-dir)))) -(declaim (ftype (function (&optional (or pathname string list)) list) +(declaim (ftype (function (&optional (or pathname string list) t) list) list-trashed-files)) -(defun list-trashed-files (&optional (trash-directories (list-trash-directories))) +(defun list-trashed-files + (&optional (trash-directories (list-trash-directories)) + include-missing) "Return a list of trashinfo objects for each trashed file in -TRASH-DIRECTORIES. TRASH-DIRECTORIES can also be a single path." - (mapcan #'list-trashed-files-for-directory +TRASH-DIRECTORIES. TRASH-DIRECTORIES can also be a single path. With +INCLUDE-MISSING, also include trashinfo files that are missing their +corresponding trashed file." + (mapcan (lambda (dir) + (list-trashed-files-for-directory dir include-missing)) (normalize-trash-directories trash-directories))) (declaim (ftype (function (trashinfo &key (:target (or string pathname)) @@ -317,7 +323,8 @@ TRASH-DIRECTORIES. TRASH-DIRECTORIES can also be a single path." t) restore-file)) (defun restore-file (trashinfo &key - (target (trashinfo-original-path trashinfo)) + (target (trashinfo-original-path trashinfo + :resolve t)) (update-size-cache t) no-cross-device) "Restore the file pointed to by TRASHINFO. If UPDATE-SIZE-CACHE is non-nil @@ -372,3 +379,13 @@ DRY-RUN just print the directories that will be removed without actually doing anything." (dolist (trashinfo (list-trashed-files trash-directories)) (empty-file trashinfo :dry-run dry-run))) + +(declaim (ftype (function ((or string pathname)) (integer 0)) + trash-directory-size)) +(defun trash-directory-size (directory) + "Return the size of all files trashed in DIRECTORY." + (loop for info in (list-trashed-files directory) + summing (or (trashed-file-size + (trashinfo-trash-directory info) + (trashinfo-name info)) + 0))) diff --git a/cl-xdg-trash/trashinfo.lisp b/cl-xdg-trash/trashinfo.lisp index 6fccdfd..a6ce3da 100644 --- a/cl-xdg-trash/trashinfo.lisp +++ b/cl-xdg-trash/trashinfo.lisp @@ -1,5 +1,38 @@ (in-package :cl-xdg-trash/trashinfo) +(declaim (ftype (function ((or string pathname)) pathname) + guess-trash-directory-root)) +(defun guess-trash-directory-root (trash-directory) + "Guess the root of TRASH-DIRECTORY." + (let ((home (cl-xdg-trash:user-home-trash-directory))) + (if (uiop:pathname-equal (ensure-nonwild-pathname trash-directory + :ensure-directory t) + home) + (parent-directory home) + (find-filesystem-root trash-directory)))) + +(defun home-trash-p (trash-directory) + "Return non-nil if TRASH-DIRECTORY is the user's home trash directory." + (uiop:pathname-equal (ensure-nonwild-pathname + trash-directory :ensure-directory t) + (cl-xdg-trash:user-home-trash-directory))) + +(declaim (ftype (function ((or string pathname)) pathname) + directory-as-file-pathname)) +(defun directory-as-file-pathname (path) + "Return PATH as a file, not a directory pathname." + (let ((path (ensure-nonwild-pathname path))) + (if (uiop:file-pathname-p path) + path + (make-pathname :name (file-or-dir-namestring path) :type nil + :directory (butlast (pathname-directory path)))))) + +(declaim (ftype (function ((or string pathname)) pathname) parent-directory)) +(defun parent-directory (path) + "Return the parent directory of PATH." + (uiop:pathname-parent-directory-pathname + (uiop:ensure-directory-pathname path))) + (define-condition trashinfo-format-error (parse-error) ((message :accessor trashinfo-format-error-message :initarg :message @@ -34,8 +67,7 @@ trashinfo file belongs to.") :initarg :name :type string :documentation "The name of this trashinfo file without the extension.") - (original-path :reader trashinfo-original-path - :initarg :original-path + (original-path :initarg :original-path :type pathname :documentation "Path to the original location of the file.") (deletion-date :reader trashinfo-deletion-date @@ -45,6 +77,39 @@ trashinfo file belongs to.") trashed.")) (:documentation "Represents a .trashinfo file.")) +(defmethod trashinfo-in-home-p ((trashinfo trashinfo)) + (home-trash-p (trashinfo-trash-directory trashinfo))) + +(defun make-path-relative (root path) + "If PATH is absolute, make it relative to ROOT." + (if (uiop:relative-pathname-p path) + path + (let ((unix-root (uiop:unix-namestring + (ensure-nonwild-pathname root :ensure-directory t))) + (unix-path (uiop:unix-namestring + (ensure-nonwild-pathname path)))) + (uiop:parse-unix-namestring + (if (uiop:string-prefix-p unix-root unix-path) + (subseq unix-path (length unix-root)) + (subseq unix-path 1)))))) + +(defmethod trashinfo-original-path ((trashinfo trashinfo) + &key resolve normalize) + (assert (not (and resolve normalize)) (resolve normalize) + "Only one of RESOVLE and NORMALIZE can be passed") + (with-slots (original-path trash-directory) trashinfo + (cond + (resolve + (merge-pathnames original-path + (guess-trash-directory-root trash-directory))) + ((and normalize (trashinfo-in-home-p trashinfo)) + (merge-pathnames original-path + (parent-directory (cl-xdg-trash:user-home-trash-directory)))) + (normalize + (make-path-relative (find-filesystem-root trash-directory) + original-path)) + (t original-path)))) + (defmethod print-object ((obj trashinfo) stream) (print-unreadable-object (obj stream :type t :identity t) (princ (trashinfo-name obj) stream))) @@ -101,7 +166,8 @@ trashed file NAME in TRASH-DIRECTORY." :directory '(:relative "info")) (ensure-nonwild-pathname trash-directory :ensure-directory t))) -(declaim (ftype (function (pathname string stream &key (:source-file pathname)) +(declaim (ftype (function ((or string pathname) string stream + &key (:source-file pathname)) trashinfo) parse-trashinfo-from-stream)) (defun parse-trashinfo-from-stream @@ -118,8 +184,11 @@ trashed file NAME in TRASH-DIRECTORY." :line-number 1 :source-file source-file :context first-line :message "First line should be \"[Trash Info]\""))) - (loop with path = nil + (loop with trash-directory = (ensure-nonwild-pathname trash-directory + :ensure-directory t) + with path = nil with deletion-date = nil + with in-home = (home-trash-p trash-directory) for line-number upfrom 2 for line = (read-line in nil) while (and line (not (and path deletion-date))) @@ -128,7 +197,15 @@ trashed file NAME in TRASH-DIRECTORY." do (cond ((and (not path) (string= line "Path" :end1 delim)) - (setq path (url-decode line :start (1+ delim)))) + (let ((found (ensure-nonwild-pathname + (url-decode line :start (1+ delim))))) + (unless (or in-home (uiop:relative-pathname-p found)) + (error 'trashinfo-format-error + :line-number line-number :context line + :source-file source-file + :message + "Absolute path outside of home trash directory")) + (setq path found))) ((and (not deletion-date) (string= line "DeletionDate" :end1 delim)) (handler-case @@ -147,10 +224,12 @@ trashed file NAME in TRASH-DIRECTORY." :context "" :source-file source-file :message "End-of-file without both \"Path\" and \"DeletionDate\"") - (return (make-instance 'trashinfo - :deletion-date deletion-date - :original-path path :name name - :trash-directory trash-directory))))) + (return (make-instance + 'trashinfo + :deletion-date deletion-date + :original-path (directory-as-file-pathname path) + :name name + :trash-directory trash-directory))))) (declaim (ftype (function ((or pathname string) string) trashinfo))) (defun parse-trashinfo-file @@ -181,12 +260,14 @@ TRASH-DIRECTORY. If SOURCE-FILE is not provided, it will be calculated." format-trashinfo)) (defun format-trashinfo (trashinfo &optional stream) "Write the trashinfo file out to STREAM." - (with-slots (original-path deletion-date) trashinfo + (with-slots (deletion-date) trashinfo (format stream "[Trash Info]~%Path=~A~%DeletionDate=~A~%" - (url-encode original-path :safe-chars '(#\/)) + (url-encode (uiop:unix-namestring + (trashinfo-original-path trashinfo :normalize t)) + :safe-chars '(#\/)) (format-trashinfo-timestamp deletion-date)))) -(declaim (ftype (function (pathname (or string pathname)) stream) +(declaim (ftype (function ((or string pathname) (or string pathname)) stream) open-trashinfo-for)) (defun open-trashinfo-for (trash-directory path) (loop with trash-directory = (ensure-nonwild-pathname trash-directory @@ -209,6 +290,15 @@ TRASH-DIRECTORY. If SOURCE-FILE is not provided, it will be calculated." until stream finally (return stream))) +(declaim (ftype (function ((or pathname string) (or pathname string)) pathname) + make-original-path)) +(defun make-original-path (trash-directory path) + "Calculate what the original path for PATH is after it is trashed to +TRASH-DIRECTORY." + (if (home-trash-p trash-directory) + (merge-pathnames path (cl-xdg-trash:user-home-trash-directory)) + (make-path-relative (find-filesystem-root trash-directory) path))) + (declaim (ftype (function (pathname (or pathname string) &optional local-time:timestamp) trashinfo) @@ -225,16 +315,20 @@ TRASH-DIRECTORY. Return a trashinfo object pointing to this file." (close stream :abort t) (signal e)))) (let ((trashinfo - (make-instance 'trashinfo - :original-path (uiop:native-namestring - (merge-pathnames path - (uiop:getcwd))) - :name (remove-suffix - (file-or-dir-namestring - (pathname stream)) - ".trashinfo") - :trash-directory trash-directory - :deletion-date deletion-date))) + (make-instance + 'trashinfo + :original-path + (directory-as-file-pathname + (make-original-path trash-directory + (merge-pathnames path (uiop:getcwd)))) + :name (remove-suffix + (file-or-dir-namestring + (pathname stream)) + ".trashinfo") + :trash-directory + (ensure-nonwild-pathname trash-directory + :ensure-directory t) + :deletion-date deletion-date))) (format-trashinfo trashinfo stream) trashinfo)) ;; if we exited successfully diff --git a/cl-xdg-trash/url-encode.lisp b/cl-xdg-trash/url-encode.lisp index 758b0c6..f7e929e 100644 --- a/cl-xdg-trash/url-encode.lisp +++ b/cl-xdg-trash/url-encode.lisp @@ -33,7 +33,7 @@ (cons (integer #b11110000 #b11110111) (cons utf-8-middle-byte (cons utf-8-middle-byte (cons utf-8-middle-byte null)))))) -(declaim (ftype (function (character) list-of-code-points) utf-8-char)) +(declaim (ftype (function (character) utf-8-char) utf-8-encode-char)) (defun utf-8-encode-char (char) "Encode CHAR, a character, to a list of bytes that make up its UTF-8 representation." diff --git a/clash/Makefile b/clash/Makefile index 790ad57..e90f938 100644 --- a/clash/Makefile +++ b/clash/Makefile @@ -1,6 +1,13 @@ LISP=sbcl -clash: clash.asd clash.lisp +all: clash + +clash: clash.asd format.lisp parse-date.lisp clash.lisp $(LISP) --eval '(ql:quickload :clash)' \ --eval '(asdf:make :clash)' \ --eval '(uiop:quit)' + +clean: + rm -f clash + +.PHONY: all clean diff --git a/clash/README.md b/clash/README.md new file mode 100644 index 0000000..25bc6b0 --- /dev/null +++ b/clash/README.md @@ -0,0 +1,19 @@ +# clash + +`clash` is command-line tool for trashing and restoring files, as well as +searching and deleting trashed files. It is inspired by the excellent +[trash-cli](https://github.com/andreafrancia/trash-cli). + +Clash depends on `cl-xdg-trash`, `cl-ppcre`, and `clingon`. `cl-xdg-trash` is +located in the same repository as `clash` and was developed alongside it. + +## Building +To build `clash`, execute +```sh +make +``` +from you're shell of choice. + +## Use +A list of subcommands can be found with `clash -h`. Each subcommand can also +take the `-h` flag to show documentation for that command. diff --git a/clash/clash.asd b/clash/clash.asd index 173e3b3..d119f3e 100644 --- a/clash/clash.asd +++ b/clash/clash.asd @@ -8,7 +8,12 @@ :depends-on (#:cl-xdg-trash #:cl-ppcre #:clingon) :serial t :components - ((:file "clash")) + ((:file "format") + (:file "parse-date") + (:file "clash")) :build-operation "program-op" :build-pathname "clash" - :entry-point "clash:toplevel") + :entry-point "clash:toplevel" + :long-description + #.(uiop:read-file-string + (uiop:subpathname *load-pathname* "README.md"))) diff --git a/clash/clash.lisp b/clash/clash.lisp index a432c98..c923b7a 100644 --- a/clash/clash.lisp +++ b/clash/clash.lisp @@ -6,13 +6,12 @@ #:trashinfo-info-file #:trashinfo-name #:trashinfo-trashed-file - #:trashinfo-deletion-date) + #:trashinfo-deletion-date + #:parse-trashinfo-file) (:import-from #:cl-xdg-trash/mountpoints #:file-or-dir-namestring #:ensure-nonwild-pathname) - (:import-from #:cl-xdg-trash/directorysizes - #:trashed-file-size) - (:use #:cl) + (:use #:cl #:clash/parse-date #:clash/format) (:export #:toplevel)) (in-package :clash) @@ -24,216 +23,110 @@ (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) - (format - stream "Failed to parse date ~S~@[ at position ~A~]: ~A" - (date-parse-error-source condition) - (date-parse-error-position condition) - (date-parse-error-message condition)))) - (:documentation "A condition representing a failure in parsing a date range.")) +;; Filtering +(defparameter *byte-count-suffixes* "kmgtpezyrq" + "Metric power suffixes used in parse-byte-count.") +(defparameter *byte-count-pattern* + (cl-ppcre:create-scanner + (format nil "^\\s*(?(?=(?:^|[^0-9])\\.[0-9])|([0-9]+))\\.?((?<=\\.)[0-9]+)?~ + \\s*(?:(?:([kmgtpezyrq])(i)?)?B)?$\\s*") + :extended-mode t + :case-insensitive-mode t) + "Regexp scanner for parse-byte-count.") -(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 make-float (int dec) + (if (zerop dec) + (float int) + (+ (float int) + (* (if (minusp int) -1 1) + (/ (float dec) + (expt 10 (1+ (floor (log dec 10))))))))) -(defun parse-month-string (str) - (loop for (num . text) in *month-conversion-table* - when (member str text :test 'equalp) - do (return num))) +(defun find-suffix-expt (suffix) + "Find the exponent for SUFFIX." + (1+ (or (position (coerce suffix 'character) + *byte-count-suffixes* :test #'equalp) + -1))) -(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 parse-byte-count (string) + "Parse a byte count from STRING." + (or (ppcre:register-groups-bind + ((#'parse-integer int dec) + (#'find-suffix-expt power) base-two) + (*byte-count-pattern* string :sharedp t) + (let ((count (* (make-float (or int 0) (or dec 0)) + (expt (if base-two 1024 1000) (or power 0))))) + (if (and (not power) (plusp (mod count 1))) + (error "Byte count is not a natural number: ~A" count) + (values (floor count))))) + (error "Not a byte count: ~S" string))) -(defun current-year () - "Return the current year." - (local-time:timestamp-year (local-time:now))) +(defun parse-byte-range (string) + "Parse STRING, which should be range of byte counts." + (destructuring-bind (&optional start end &rest rest) + (uiop:split-string string :separator '(#\- #\: #\~)) + (when rest + (error "Garbage after byte range: ~S" string)) + (cond + ((and (plusp (length start)) + (plusp (length end))) + (cons (parse-byte-count start) + (parse-byte-count end))) + ((and (plusp (length start)) + (stringp end)) + (cons (parse-byte-count start) nil)) + ((stringp end) + (cons 0 (parse-byte-count end))) + ((plusp (length start)) + (let ((n (parse-byte-count start))) + (cons n n))) + (t (error "Not a byte range: ~S" string))))) -(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." +(defun number-in-byte-ranges (num ranges) + "Return non-nil if NUM falls within 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)))) + (and (>= num (car range)) + (or (not (cdr range)) + (<= num (cdr range))))) 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")) +(defun print-byte-range-help (stream) + "Print information about byte range parsing to STREAM." + (format stream "~ +Byte counts take the form of a number with an optional size suffix. Some +examples follow (all supported suffixes are listed at the end): + \"32\" - 32 bytes + \"51B\" - 51 bytes (space between the number and unit is optional) + \"3.1B\" - (INVALID) fractional count of bytes + \".3 KiB\" - 307 bytes (the .2 is rounded off) + \"1.3 kB\" - 1300 bytes (1.3 kilobytes) + \"5.3 MiB\" - 5300000 bytes (5.3 mebibytes) +Byte ranges take the form of one or two byte counts separated by a \"-\", \":\", +or \"~~\". If one count is given with no separator, items of exactly that size +match. Otherwise, items between the bounds of the range (inclusive of those +bounds) match. If the lower bound of a range is omitted (but the separator still +present), the lower bound is zero. If the upper bound is omitted, there is no +upper bound. Some examples: + \"30\" - exactly 30 bytes + \"-5TB\" - less that or equal to 5 terabytes + \"10GiB:\" - greater than or equal to 10 gibigytes + \"10kB-30kB\" - between 10 kilobytes and 30 kilobytes (inclusive) +Ranges are provided to commands that support them via the -S or --size-range +flags. These flags can be given any number of times and anything that lies +within at at least one range will match (that is, the union of all ranges). -(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)) +The following suffixes are recognized (in additon to \"B\"): ++----------------------+----------------------+ +| ~20:@ | ~20:@ | ++----------------------+----------------------+ +~:{| ~20@<~:@(~A~)B - 1000^~D~> | ~@*~20@<~:@(~A~)iB - 1024^~D~> |~%~}~ ++----------------------+----------------------+~%" + (loop for c across *byte-count-suffixes* + for i upfrom 1 + collect (list c i)))) -(defmethod clingon:make-option ((kind (eql :date-range)) &rest args) - (apply #'make-instance 'option-date-range args)) - - -;; Filtering -(defun clingon-filtering-options () - "Return some options that can be used by many commands for filtering." +(defun clingon-dir-options () + "Return some options that can be used by many commands." (list (clingon:make-option :list/filepath @@ -245,60 +138,75 @@ date ranges..")) :list/filepath :key :ignored-trashes :description "ignore the given trash directory" + :short-name #\I :long-name "ignore-trash") (clingon:make-option :flag :key :only-explicit-dirs :description "only use trash directories supplied with -c" :short-name #\E - :long-name "explicit-trashes-only") - (clingon:make-option - :flag - :key :print-format-info - :description "print information about format strings, then exit" - :long-name "format-info") - (clingon:make-option - :flag - :key :strings - :description "don't use regexp to match file names" - :short-name #\s - :long-name "strings") - (clingon:make-option - :flag - :key :exact - :description "force exact match" - :short-name #\e - :long-name "exact") - (clingon:make-option - :flag - :key :full-path - :description "match against full file paths" - :short-name #\p - :long-name "full-paths") - (clingon:make-option - :flag - :key :case-insensitive - :description "match case-insensitively" - :short-name #\i - :long-name "case-insensitive") - (clingon:make-option - :flag - :key :invert - :description "invert result" - :short-name #\v - :long-name "invert") - (clingon:make-option - :string - :key :format - :description "format to print results in" - :short-name #\f - :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"))) + :long-name "explicit-trashes-only"))) + +(defun clingon-filtering-options () + "Return some options that can be used by many commands for filtering." + (append + (clingon-dir-options) + (list + (clingon:make-option + :flag + :key :strings + :description "don't use regexp to match file names" + :short-name #\s + :long-name "strings") + (clingon:make-option + :flag + :key :exact + :description "force exact match" + :short-name #\e + :long-name "exact") + (clingon:make-option + :flag + :key :full-path + :description "match against full file paths" + :short-name #\p + :long-name "full-paths") + (clingon:make-option + :flag + :key :case-insensitive + :description "match case-insensitively" + :short-name #\i + :long-name "case-insensitive") + (clingon:make-option + :flag + :key :invert + :description "invert result" + :short-name #\v + :long-name "invert") + (clingon:make-option + :date-range + :key :date-ranges + :description "range of dates to consider in search" + :short-name #\R + :long-name "date-range") + (clingon:make-option + :flag + :key :date-help + :description "print information about date ranges" + :long-name "date-help") + (clingon:make-option + :multi-parsed + :key :size-ranges + :description + "range of file sizes to consider in search (suffixes like GB or KiB work)" + :parser #'parse-byte-range + :parameter "RANGE" + :short-name #\S + :long-name "size-range") + (clingon:make-option + :flag + :key :size-help + :description "print information about size ranges" + :long-name "size-help")))) (declaim (inline compare-trashinfo-to-string)) (defun compare-trashinfo-to-string (trashinfo filter full-path exact @@ -355,13 +263,18 @@ string." (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) +(defun limit-trashinfo-dates-and-sizes-for-cmd (cmd trashinfos) + (let ((dates (clingon:getopt cmd :date-ranges)) + (sizes (clingon:getopt cmd :size-ranges))) + (if (and (not dates) (not sizes)) trashinfos (delete-if (lambda (info) - (not (timestamp-in-ranges (trashinfo-deletion-date info) - ranges))) + (or (and dates + (not (timestamp-in-ranges + (trashinfo-deletion-date info) dates))) + (and sizes + (not (number-in-byte-ranges + (or (trashinfo-size info) 0) sizes))))) trashinfos)))) (defun list-trashinfos-for-cmd (cmd) @@ -369,7 +282,7 @@ string." (let ((args (clingon:command-arguments cmd))) (when (cdr args) (clingon:print-usage-and-exit cmd t)) - (limit-trashinfo-dates-for-cmd + (limit-trashinfo-dates-and-sizes-for-cmd cmd (if (not (car args)) (cl-xdg-trash:list-trashed-files (list-nonexcluded-trash-dirs cmd)) @@ -389,147 +302,6 @@ string." :case-insensitive case-insensitive :invert invert)))))) - -;; Formatting -(defun format-size (count &optional base-two (places 2)) - "Pretty print COUNT, which is a number of bytes. This will append metric -suffixes as necessary. If BASE-TWO is non-nil, use MiB, GiB, etc. suffixes -instead." - (if (not count) - "N/A" ;; if find the size of something failed - (let* ((base (if base-two 1024 1000)) - (power (min 10 (floor (if (zerop count) 0 (log count base)))))) - (if (zerop power) - (format nil "~DB" count) - (format nil "~,VF~[~:[k~;K~]~:*~;M~;G~;T~;P~;E~;Z~;Y~;R~;Q~]~@[i~]B" - places (/ count (expt base power)) - (1- power) base-two))))) - -(defparameter *trashinfo-formatters* - `((#\# :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)") - (#\s ,(lambda (stream info) - (format stream "~A" (trashed-file-size - (trashinfo-trash-directory info) - (trashinfo-name info)))) - "the file's (s)size in bytes") - (#\h ,(lambda (stream info) - (format stream "~A" - (format-size (trashed-file-size - (trashinfo-trash-directory info) - (trashinfo-name info))))) - "the file's size with a (h)uman readable suffix (powers of 10)") - (#\H ,(lambda (stream info) - (format stream "~A" - (format-size (trashed-file-size - (trashinfo-trash-directory info) - (trashinfo-name info)) - t))) - "the file's size with a (H)uman readable suffix (power of 2)") - (#\% ,(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." - (let ((start 0) - out end) - (labels ((ensure-next-char (i thing) - (unless (< i (1- (length format-string))) - (error "Unterminated ~A at char ~A: ~S" thing i format-string))) - (unknown (i thing) - (error "Unknown ~A at char ~A: ~S" thing i format-string)) - (push-thing (thing) - (if (null out) - (setq out (list thing) - end out) - (setf (cdr end) (list thing) - end (cdr end)))) - (push-string (str) - (unless (zerop (length str)) - (if (stringp (car end)) - (setf (car end) (format nil "~A~A" (car end) str)) - (push-thing str))))) - (do ((i 0 (1+ i))) - ((>= i (length format-string))) - (case (aref format-string i) - (#\% - (ensure-next-char i "substitution") - (push-string (subseq format-string start i)) - (let ((fun (second (assoc (aref format-string (1+ i)) - *trashinfo-formatters*)))) - (unless fun - (unknown i "substitution")) - (push-thing fun)) - (setq start (+ i 2) - i (1+ i))) - (#\\ - (ensure-next-char i "escape sequence") - (push-string (subseq format-string start i)) - (push-string - (case (aref format-string (1+ i)) - (#\\ "\\") - (#\n (string #\Newline)) - (#\t (string #\Tab)) - (#\0 (string #\Nul)) - (t (unknown i "escape sequence")))) - (setq start (+ i 2) - i (1+ i))))) - (push-string (subseq format-string start)) - out))) - -(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) - (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 "~ -Format strings use C-style and printf-style escape sequences. Each character -other than one of those with a special meaning noted below is copied to the -output verbatim. The recognized C-style escapes sequences are: - \"\\0\" - null byte - \"\\n\" - newline - \"\\t\" - tab character - \"\\\\\" - literal backslash -The recognizes printf-style sequences are (parenthesis denote the mnemonic):~%") - (dolist (entry *trashinfo-formatters*) - (let ((char (first entry)) - (doc (third entry))) - (format stream " \"%~A\" - ~A~%" char doc)))) - ;; Sorting (defun clingon-sort-options () @@ -549,7 +321,8 @@ The recognizes printf-style sequences are (parenthesis denote the mnemonic):~%") :long-name "sort-field" :items '(("name" . :name) ("path" . :path) - ("deletion-date" . :deletion-date)) + ("deletion-date" . :deletion-date) + ("size" . :size)) :initial-value "deletion-date"))) (defun sort-trashinfos-for-cmd (trashinfos cmd) @@ -559,32 +332,116 @@ The recognizes printf-style sequences are (parenthesis denote the mnemonic):~%") (:name (values #'string-lessp (lambda (info) (file-or-dir-namestring (trashinfo-original-path info))))) - (:path (values #'string-lessp #'trashinfo-original-path)) + (:path (values #'string-lessp + (lambda (info) + (uiop:unix-namestring + (trashinfo-original-path info :resolve t))))) (:deletion-date (values #'< (lambda (info) (local-time:timestamp-to-unix - (trashinfo-deletion-date info)))))) + (trashinfo-deletion-date info))))) + (:size (values (lambda (s1 s2) + ;; if finding the file's size fails, either of these + ;; may be nil + (cond + ((not s1) t) + ((not s2) nil) + ((< s1 s2)))) + #'trashinfo-size))) (sort trashinfos (if (clingon:getopt cmd :reverse-sort) (complement pred-fun) pred-fun) :key key-fun))) + +;; Formatting +(defun clingon-format-options (file-default &optional dir-default) + "Return a list of formatting options that can be used by many commands." + (append + (list + (clingon:make-option + :flag + :key :format-help + :description "print information about format strings, then exit" + :long-name "format-help") + (clingon:make-option + :format-string + :key :file-format + :directives *trashinfo-formatters* + :description "format for printing individual trashed files" + :short-name #\f + :long-name "file-format" + :initial-value file-default)) + (when dir-default + (list + (clingon:make-option + :flag + :key :directory-wise + :description "operate on trash directories rather than on trashed files" + :short-name #\d + :long-name "direcotries") + (clingon:make-option + :flag + :key :all-directories + :description "even show directories that have no results" + :short-name #\D + :long-name "all-directories") + (clingon:make-option + :format-string + :key :dir-format + :directives *directory-formatters* + :description "format for printing trash directories" + :short-name #\F + :long-name "directory-format" + :initial-value dir-default))))) + +(defun parition-trashinfos (infos) + "Partition INFOS into a list of conses with the car being the path of the +trash directory and the cdr being it's trashinfos. As a second value, return a +list of trash directories that were present in INFOS." + (let ((out (make-hash-table :test #'equal))) + (loop for info in infos + for dir = (uiop:unix-namestring (trashinfo-trash-directory info)) + do (setf (gethash dir out) (cons info (gethash dir out)))) + (loop for dir being the hash-keys of out + using (hash-value infos) + collect (cons dir infos) into path-and-infos + collect dir into dirs + finally (return (values path-and-infos dirs))))) + +(defun list-objects-for-command (cmd &optional no-sort) + "List either individual trashinfos or partitioned trashinfos for CMD." + (let ((infos (list-trashinfos-for-cmd cmd)) + (all-dirs (clingon:getopt cmd :all-directories))) + (cond + ((clingon:getopt cmd :directory-wise) + (multiple-value-bind (path-and-infos dirs) (parition-trashinfos infos) + (nconc path-and-infos + (mapcar #'list + (when all-dirs + (set-difference (cl-xdg-trash:list-trash-directories) + dirs :test #'uiop:pathname-equal)))))) + (all-dirs (error "Can't have -D without -d")) + (no-sort infos) + (t (sort-trashinfos-for-cmd infos cmd))))) + +(defun print-objects-for-command (cmd objs &optional (indices t) extra-action) + "Print OBJS, a list of trashinfos or trash directories, for CMD." + (if (clingon:getopt cmd :directory-wise) + (format-list t (clingon:getopt cmd :dir-format) objs indices extra-action) + (format-list t (clingon:getopt cmd :file-format) objs indices extra-action))) + ;; List command (defun list/handler (cmd) "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")))) - (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))))) + (let ((objs (list-objects-for-command cmd))) + (print-objects-for-command cmd objs))) (defun list/options () "Return options for the \"list\" subcommand." (append + (clingon-format-options "%t %o\\n" "Found %c file%m in %p\\n") (clingon-filtering-options) (clingon-sort-options))) @@ -645,6 +502,36 @@ The recognizes printf-style sequences are (parenthesis denote the mnemonic):~%") "Return non-nil if LIST has only one thing." (and list (null (cdr list)))) +(declaim (inline enumerate-range)) +(defun enumerate-range (start end) + "Enumerate all numbers between [start,end]." + (loop for i upfrom (min start end) + upto (max start end) + collect i)) + +(defun parse-index-or-range (max string) + "Parse the index or range of indices STRING." + (flet ((parse (str) + (let ((n (parse-integer str))) + (when (or (< n 1) + (> n max)) + (error "Number ~D out of range [1,~D]" n max)) + (1- n)))) + (let ((parts (uiop:split-string string :separator '(#\-)))) + (destructuring-bind (start &optional end &rest rest) + (mapcar (lambda (part) (string-trim '(#\Space #\Tab) part)) parts) + (cond + (rest (error "Invalid range: ~S" string)) + ((and (not (zerop (length start))) + (not (zerop (length end)))) + (enumerate-range (parse start) (parse end))) + ((not (zerop (length end))) + (enumerate-range 0 (parse end))) + ((and (not (zerop (length start))) (stringp end)) + (enumerate-range (parse start) (1- max))) + ;; if none of the above match, it must be just a number + (t (list (parse string)))))))) + (defun prompt-for-index (stream action max &optional allow-many) "Prompt the user for an index between 1 and MAX to restore. With ALLOW-MANY, return a list of many indices instead." @@ -652,103 +539,149 @@ return a list of many indices instead." (error "Nothing found...")) (format stream "~&Select ~:[indices~;index~] to ~A: " (or (eql 1 max) (not allow-many)) action) - (let ((resp-string (read-line stream nil)) - (seperators '(#\Space #\Tab #\,))) + (let ((resp-string (read-line stream nil))) (unless resp-string (error "No number provided")) - (let ((parts (uiop:split-string resp-string - :separator seperators)) + (let ((parts (uiop:split-string resp-string :separator '(#\,))) (out (make-hash-table :test #'eql))) (unless parts (error "No number provided")) - (unless (or allow-many - (single-item-list-p parts)) - (error "Only one item can be selected")) (dolist (part parts) - (unless (every (lambda (c) (member c seperators)) part) - (let ((n (parse-integer part))) - (when (or (< n 1) - (> n max)) - (error "Number ~A out of range [1,~A]" n max)) - (setf (gethash (1- n) out) t)))) - (loop for key being the hash-keys of out collect key)))) + (dolist (n (parse-index-or-range max part)) + (setf (gethash n out) t))) + (let ((final-list (loop for key being the hash-keys of out collect key))) + (unless (or allow-many (single-item-list-p parts)) + (error "Only one item can be selected")) + final-list)))) + +(defun prompt-yes-or-no (stream control &rest args) + "Prompt the user for a yes or no response." + (when control + (apply #'format stream control args) + (format stream "? (y/n) ")) + (let ((resp-string (read-line stream nil))) + (when resp-string + (member resp-string '("yes" "y" "1") :test #'equalp)))) + +(defun confirm-action (action count quiet) + "Confirm with the user that ACTION is OK." + (prompt-yes-or-no + t "Really ~A ~@[~*the above ~]~@[~*~A~:* ~]item~P" + action (not quiet) (or quiet (/= 1 count)) count)) + +(defun get-indices-for-command (action cmd only-one-flag objs) + "Return indices for CMD." + (let* ((max (length objs)) + (all (clingon:getopt cmd :all)) + (indices (mapcar + (lambda (i) + (when (or (< i 1) + (> i max)) + (error "Index ~D out of range [1,~D]" i max)) + (1- i)) + (clingon:getopt cmd :indices))) + (yes (clingon:getopt cmd :yes)) + (quiet (clingon:getopt cmd :quiet)) + (dont-prompt-only-one (clingon:getopt cmd :dont-prompt-only-one))) + (when only-one-flag + (when all + (error "Can't use -a and ~A together" only-one-flag)) + (when (and indices + (not (single-item-list-p indices))) + (error "Cant use multiple -n and ~A together" only-one-flag))) + (when (and indices all) + (error "Can't use -a and -n together")) + (unless (or yes quiet) + (print-objects-for-command cmd objs (or indices t))) + (cond + ((not objs) (unless quiet + (error "Nothing to do..."))) + ((and dont-prompt-only-one (single-item-list-p objs)) + (list 0)) + (all (if (or yes + (confirm-action action max (or yes quiet))) + (enumerate-range 0 (1- max)) + :cancel)) + (indices (if (or yes + (confirm-action action (length indices) + (or yes quiet))) + indices + :cancel)) + (yes (error "One of -a or -n must be passed with -y")) + (quiet (error "One of -a or -n must be passed with -q")) + (t (prompt-for-index t action max (not only-one-flag)))))) + +(defun clingon-indices-options (action) + "Return options for prompting the user for indices." + (list + (clingon:make-option + :flag + :key :all + :description + (format nil "~A all things that match the pattern" action) + :short-name #\a + :long-name "all") + (clingon:make-option + :list/integer + :key :indices + :description + (format nil "~A the Nth thing that matched the pattern (after sorting)" + action) + :short-name #\n + :long-name "nth") + (clingon:make-option + :flag + :key :dont-prompt-only-one + :description "don't prompt if the pattern matches only one thing" + :short-name #\O + :long-name "dont-prompt-only-one") + (clingon:make-option + :flag + :key :quiet + :description (format nil "don't enumerate all options before ~Aing" action) + :short-name #\q + :long-name "quiet") + (clingon:make-option + :flag + :key :yes + :description "don't prompt, just ~A all matching things" + :short-name #\y + :long-name "yes"))) (defun restore/handler (cmd) "Handler for the \"restore\" 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"))) - (infos (list-trashinfos-for-cmd cmd)) - (target (clingon:getopt cmd :target)) - (all (clingon:getopt cmd :all)) - (cli-indices (clingon:getopt cmd :indices))) - (when (and all target) - (error "Only one of -a and -t can be supplied")) - (cond - ((and (clingon:getopt cmd :dont-prompt-only-one) - (single-item-list-p infos)) - (cl-xdg-trash:restore-file (car infos))) - ((clingon:getopt cmd :all) - (mapc #'cl-xdg-trash:restore-file infos)) - (cli-indices - (unless infos - (error "Nothing found...")) - (loop with sorted-arr = (sort-trashinfos-for-cmd - (coerce infos 'vector) cmd) - for i in cli-indices - when (or (> i (length sorted-arr)) - (< i 1)) - do (error "Index ~S out of bounds [1,~S]" - i (length sorted-arr)) - do (cl-xdg-trash:restore-file (aref sorted-arr (1- i))))) - (t - (let ((sorted-arr (coerce infos 'vector))) - (sort-trashinfos-for-cmd sorted-arr cmd) - (loop for info across sorted-arr - for i upfrom 1 - do (format-trashinfo t format info :index i)) - (let ((idxs (prompt-for-index t "restore" - (length sorted-arr) - (not target)))) - (if target - (cl-xdg-trash:restore-file (aref sorted-arr (car idxs)) - :target target) - (loop for i in idxs - do (cl-xdg-trash:restore-file - (aref sorted-arr i))))))))))) + (let* ((quiet (clingon:getopt cmd :quiet)) + (no-sort (and (clingon:getopt cmd :all) quiet)) + (infos (list-objects-for-command cmd no-sort)) + (target (clingon:getopt cmd :target)) + (indices (get-indices-for-command "restore" cmd + (when target "-t") + infos))) + ;; ensure we actually have a list of trashinfos + (assert (or (null infos) (not (listp (car infos))))) + (unless (eq indices :cancel) + (assert (or (not target) (single-item-list-p indices))) + (if target + (cl-xdg-trash:restore-file (nth (car indices) infos) :target target) + (loop with arr = (coerce infos 'vector) + for i in indices + do (format t "~A~%" (aref arr i)) + do (cl-xdg-trash:restore-file (aref arr i))))))) (defun restore/options () "Return options for the \"restore\" subcommand." (append (clingon-filtering-options) (clingon-sort-options) + (clingon-format-options "%>#: %t %o\\n") + (clingon-indices-options "restore") (list (clingon:make-option :filepath :key :target :description "where path to restore the file (exclusive with -a)" :short-name #\t - :long-name "target") - (clingon:make-option - :flag - :key :all - :description "restore all files that match the pattern (exclusive with -t)" - :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 - :description "don't prompt if the pattern matches only one file" - :short-name #\O - :long-name "dont-prompt-only-one")))) + :long-name "target")))) (defun restore/command () "Rethrn the Clingon command for the \"restore\" subcommand." @@ -761,107 +694,39 @@ return a list of many indices instead." ;; Empty command -(defun prompt-yes-or-no (stream control &rest args) - "Prompt the user for a yes or no response." - (when control - (apply #'format stream control args) - (format stream "? (y/n) ")) - (let ((resp-string (read-line stream nil))) - (when resp-string - (member resp-string '("yes" "y" "1") :test #'equalp)))) - -(defun prompt-to-empty (count quiet) - "Prompt for emptying the trash for the \"empty\" command. Specifically, used -with -n and -a." - (prompt-yes-or-no - t "Really erase ~@[~*the above ~]~@[~*~A~:* ~]file~P" - (not quiet) (or quiet (/= 1 count)) count)) - (defun empty/handler (cmd) "Handler for the \"empty\" subcommand." - (cond - ((clingon:getopt cmd :print-format-info) - (print-format-info t)) - (t - (let ((format (process-format-string - (or (clingon:getopt cmd :format) - "%#: %t %o\\n"))) - (dry-run (clingon:getopt cmd :dry-run)) - (infos (coerce (list-trashinfos-for-cmd cmd) 'vector)) - (quiet (clingon:getopt cmd :quiet)) - (yes (clingon:getopt cmd :yes)) - (all (clingon:getopt cmd :all)) - (indices (clingon:getopt cmd :indices))) - (when (and yes (not (or all indices))) - (error "Found -y with neither -a nor -n, doing nothing")) - (when (and quiet (not (or all indices))) - (error "Found -q with neither -a nor -n, doing nothing")) - (when (and (zerop (length infos)) (not quiet)) - (error "Nothing found...")) - (unless all - (sort-trashinfos-for-cmd infos cmd)) - (unless (or yes quiet) - (loop for info across infos - for i upfrom 1 - when (or (not indices) (member i indices)) - do (format-trashinfo t format info :index i))) - (cond - (all - (when (or yes (prompt-to-empty (length infos) quiet)) - (loop for info across infos - do (cl-xdg-trash:empty-file info :dry-run dry-run)))) - (indices - (when (or yes (prompt-to-empty (length indices) quiet)) - (loop for i in indices - when (or (< i 1) - (> i (length infos))) - do (error "Index ~A out of bounds [1,~A]" - i (length infos)) - else - do (cl-xdg-trash:empty-file (aref infos (1- i)) - :dry-run dry-run)))) - (t - (let ((index (prompt-for-index t "erase" (length infos) t))) - (dolist (i index) - (cl-xdg-trash:empty-file (aref infos i) :dry-run dry-run))))))))) + (let* ((dir-wise (clingon:getopt cmd :directory-wise)) + (dry-run (clingon:getopt cmd :dry-run)) + (quiet (clingon:getopt cmd :quiet)) + (no-sort (and (clingon:getopt cmd :all) quiet)) + (objs (list-objects-for-command cmd no-sort)) + (indices (get-indices-for-command "erase" cmd nil objs))) + (unless (eq indices :cancel) + (if dir-wise + (loop with objs-arr = (coerce objs 'vector) + for i in indices + do (dolist (info (cdr (aref objs-arr i))) + (cl-xdg-trash:empty-file info :dry-run dry-run))) + (loop with infos-arr = (coerce objs 'vector) + for i in indices + do (cl-xdg-trash:empty-file (aref infos-arr i) + :dry-run dry-run)))))) (defun empty/options () "Return options for the \"empty\" subcommand." (append (clingon-filtering-options) (clingon-sort-options) + (clingon-format-options "%>#: %t %o\\n" "%>: %p\\n") + (clingon-indices-options "erase") (list (clingon:make-option :flag :key :dry-run :description "print what would happen without actually deleting anything" - :short-name #\D - :long-name "dry-run") - (clingon:make-option - :flag - :key :all - :description "erase all matching files" - :short-name #\a - :long-name "all") - (clingon:make-option - :list/integer - :key :indices - :description - "erase the Nth file that matched the pattern (after sorting)" - :short-name #\n - :long-name "nth") - (clingon:make-option - :flag - :key :yes - :description "erase files without prompting (implies -q)" - :short-name #\y - :long-name "yes") - (clingon:make-option - :flag - :key :quiet - :description "be less verbose" - :short-name #\q - :long-name "quiet")))) + :short-name #\N + :long-name "dry-run")))) (defun empty/command () "Return the Clingon command for the \"empty\" subcommand." @@ -927,16 +792,152 @@ with -n and -a." ;; Size command (defun size/handler (cmd) "Handler for the \"size\" subcommand." - ) + (let* ((quiet (clingon:getopt cmd :quiet)) + (objs (list-objects-for-command cmd quiet)) + (dir-wise (clingon:getopt cmd :directory-wise)) + (base-two (clingon:getopt cmd :base-two)) + (bytes (clingon:getopt cmd :bytes)) + (total-size 0)) + (when (and bytes base-two) + (error "Can't pass both -t and -b")) + (flet ((sum (size) + (when size (incf total-size size)))) + (cond + ((and quiet dir-wise) + (dolist (path-and-infos objs) + (dolist (info (cdr path-and-infos)) + (sum (trashinfo-size info))))) + (quiet + (dolist (info objs) + (sum (trashinfo-size info)))) + (dir-wise + (print-objects-for-command + cmd objs t (lambda (path-and-infos) + (dolist (info (cdr path-and-infos)) + (sum (trashinfo-size info)))))) + (t + (print-objects-for-command + cmd objs t (lambda (info) + (sum (trashinfo-size info))))))) + (format t "~@[~*Total Size: ~]~A" + (not quiet) (if bytes + total-size + (format-size total-size base-two))))) (defun size/options () "Return options for the \"size\" subcommand." - (list - ())) + (append + (clingon-filtering-options) + (clingon-sort-options) + (clingon-format-options "%= i (length format-string))) + (case (aref format-string i) + (#\% + (ensure-next-char i "substitution") + (push-string (subseq format-string start i)) + (let* ((start-i i) + (next-c (aref format-string (1+ i))) + (pad-type (case next-c (#\< :left) (#\> :right) (t nil)))) + (when pad-type + (ensure-next-char (1+ i) "substitution") + (setq next-c (aref format-string (+ i 2))) + (incf i) + (incf start)) + (setq start (+ i 2) + i (1+ i)) + (case next-c + (#\% (push-string "%")) + (#\# (push-thing (if pad-type + (cons :index pad-type) + :index))) + (t (let ((code (find next-c directives :key #'format-code-name))) + (unless (typep code 'format-code) + (unknown start-i "substitution")) + (unless (or (not pad-type) (format-code-padder code)) + (error "Format code %~A does not support padding" next-c)) + (push-thing (if pad-type (cons code pad-type) code))))))) + (#\\ + (ensure-next-char i "escape sequence") + (push-string (subseq format-string start i)) + (push-string + (case (aref format-string (1+ i)) + (#\\ "\\") + (#\n (string #\Newline)) + (#\t (string #\Tab)) + (#\0 (string #\Nul)) + (t (unknown i "escape sequence")))) + (setq start (+ i 2) + i (1+ i))))) + (push-string (subseq format-string start)) + out))) + +(defclass option-format-string (clingon:option) + ((directives :accessor option-format-string-directives + :type list + :initarg :directives + :documentation "The format directives to use when parsing.") + (format-string :accessor option-format-string-format-string + :type string + :initform "" + :documentation "The used-passed format string.")) + (:default-initargs :parameter "FORMAT-CONTROL") + (:documentation "Option that takes a format string.")) + +(defmethod clingon:initialize-option ((option option-format-string) &key) + (setf (option-format-string-format-string option) + (clingon:option-initial-value option)) + (call-next-method)) + +(defmethod clingon:derive-option-value ((option option-format-string) arg &key) + (setf (option-format-string-format-string option) arg)) + +(defmethod clingon:finalize-option ((option option-format-string) &key) + (parse-format-string (option-format-string-format-string option) + (option-format-string-directives option))) + +(defmethod clingon:make-option ((kind (eql :format-string)) &rest args) + (apply #'make-instance 'option-format-string args)) + +(defun number-length (n &optional (base 10)) + "Return the number of digits in N when represented in BASE. If N is ngeative, +add one to the result." + (if (zerop n) + 1 + (+ (floor (log (abs n) base)) (if (minusp n) 2 1)))) + +(defun format-object (stream control-obj obj + &key (index 1) (max-index 1) + (max-index-length (number-length max-index))) + "Format the object OBJ to STREAM according to CONTROL-OBJECT (which is from +parse-format-string)." + (dolist (part control-obj) + (cond + ((eq :index part) + (format stream "~A" index)) + ((and (consp part) (eq :index (car part))) + (case (car part) + (:left (format stream "~VD" max-index-length index)) + (:right (format stream "~V@<~D~>" max-index-length index)) + (t (format stream "~A" index)))) + ((stringp part) + (format stream "~A" part)) + ((and (consp part)) + (with-slots (padder action) (car part) + (funcall padder stream (cdr part) + (with-output-to-string (tmp-output) + (funcall action tmp-output obj)) + obj))) + (t (funcall (format-code-action part) stream obj))))) + +(defun format-list (stream control-obj objs &optional (indices t) extra-action) + "Format a list of objects OBJS with format-object." + (if (eq t indices) + (loop with max-index = (length objs) + with max-index-length = (number-length max-index) + for obj in objs + for i upfrom 1 + do (format-object stream control-obj obj :index i + :max-index max-index + :max-index-length + max-index-length) + when extra-action + do (funcall extra-action obj)) + (loop with max-index = (reduce #'max indices :initial-value 0) + with max-index-length = (number-length max-index) + with objs-arr = (coerce objs 'vector) + for index in indices + do (format-object stream control-obj (aref objs-arr index) + :index (1+ index) :max-index max-index + :max-index-length max-index-length) + when extra-action + do (funcall extra-action (aref objs-arr index))))) + +(defun print-format-info (stream &rest name-directive-pairs) + (format stream "~ +Format strings use C-style and printf-style escape sequences. Each character +other than one of those with a special meaning noted below is copied to the +output verbatim. The recognized C-style escapes sequences are: + \"\\0\" - null byte + \"\\n\" - newline + \"\\t\" - tab character + \"\\\\\" - literal backslash~%~%") + (loop for (name directive . rest) = name-directive-pairs then rest + for first = t then nil + while name + when first + do (format stream "~ +(Sequences with a \"*\" before them support padding by putting a < or > after +the initial % character)~%") + do (format stream "~ +The recognized printf-style sequences for ~A are: + \"%%\" - a literal % + *\"%#\" - the index of the current item (used when prompting)~%" name) + do (dolist (code (sort (copy-list directive) #'char-lessp + :key #'format-code-name)) + (with-slots (name doc padder) code + (format stream " ~:[ ~;*~]\"%~A\"~@[ - ~A~]~%" + padder name doc))) + when rest + do (terpri stream))) + +(defun make-fixed-with-padder (width) + "Return a padder (for a format-code)" + (lambda (stream pad-type text obj) + (declare (ignore obj)) + (case pad-type + (:left (format stream "~V@<~A~>" width text)) + (:right (format stream "~V<~A~>" width text)) + (t (format stream "~A" text))))) + +(defparameter *trashinfo-formatters* + (list + (make-format-code + :name #\o + :action (lambda (stream info) + (format stream "~A" (trashinfo-original-path info :resolve t))) + :doc "the (o)riginal path (always absolute)") + (make-format-code + :name #\O + :action (lambda (stream info) + (format stream "~A" (trashinfo-original-path info :normalize t))) + :doc "the (o)riginal path (possibly relative)") + (make-format-code + :name #\n + :action (lambda (stream info) + (format stream "~A" (file-or-dir-namestring + (trashinfo-original-path info)))) + :doc "the original (n)ame") + (make-format-code + :name #\d + :action (lambda (stream info) + (format stream "~A" (trashinfo-trash-directory info))) + :doc "the trash (d)irectory") + (make-format-code + :name #\i + :action (lambda (stream info) + (format stream "~A" (trashinfo-info-file info))) + :doc "the trash(i)nfo file path") + (make-format-code + :name #\c + :action (lambda (stream info) + (format stream "~A" (trashinfo-trashed-file info))) + :doc "the (c)urrent (trashed) path") + (make-format-code + :name #\u + :action (lambda (stream info) + (format stream "~A" (local-time:timestamp-to-unix + (trashinfo-deletion-date info)))) + :doc "the time the file was trashed (in (u)TC seconds)") + (make-format-code + :name #\t + :action (lambda (stream info) + (local-time:format-timestring + stream (trashinfo-deletion-date info) + :format local-time:+asctime-format+)) + :doc "the (t)ime the file was trashed (pretty-printed local time)") + (make-format-code + :name #\s + :action (lambda (stream info) + (format stream "~A" (trashinfo-size info))) + :doc "the file's (s)size in bytes") + (make-format-code + :name #\h + :action (lambda (stream info) + (format stream "~A" + (format-size (trashinfo-size info)))) + :padder (make-fixed-with-padder 9) + :doc "the file's size with a (h)uman readable suffix (powers of 10)") + (make-format-code + :name #\H + :action (lambda (stream info) + (format stream "~A" + (format-size (trashinfo-size info) t))) + :padder (make-fixed-with-padder 10) + :doc "the file's size with a (H)uman readable suffix (power of 2)"))) + +(defun trashinfo-list-size (infos) + "Return the sum of the sizes of each trashinfo in INFOS." + (loop for info in infos + summing (or (trashinfo-size info) 0))) + +(defparameter *directory-formatters* + (list + (make-format-code + :name #\p + :action (lambda (stream path-and-infos) + (format stream "~A" (uiop:native-namestring + (uiop:ensure-directory-pathname + (car path-and-infos))))) + :doc "the directory's (p)ath (with a trailing slash)") + (make-format-code + :name #\s + :action (lambda (stream path-and-infos) + (format stream "~D" (trashinfo-list-size (cdr path-and-infos)))) + :doc "the directory's (s)ize (in bytes)") + (make-format-code + :name #\h + :action (lambda (stream path-and-infos) + (format stream "~A" (format-size + (trashinfo-list-size (cdr path-and-infos))))) + :padder (make-fixed-with-padder 9) + :doc "the directory's size with a (h)uman readable suffix (powers of 10)") + (make-format-code + :name #\H + :action (lambda (stream path-and-infos) + (format stream "~A" + (format-size (trashinfo-list-size (cdr path-and-infos)) t))) + :padder (make-fixed-with-padder 10) + :doc "the directory's size with a (H)uman readable suffix (powers of 2)") + (make-format-code + :name #\c + :action (lambda (stream path-and-infos) + (format stream "~D" (length (cdr path-and-infos)))) + :doc "the (c)ount of files trashed in the directory") + (make-format-code + :name #\m + :action (lambda (stream path-and-infos) + (let ((infos (cdr path-and-infos))) + (format stream "~@[s~]" (or (null infos) (cdr infos))))) + :doc "nothing if only one file was found in this directory, otherwise \"s\""))) + +(defun print-clash-format-info (&optional (print-dir t) (stream t)) + "Print format string information for clash to STREAM." + (apply #'print-format-info + stream + "trashed files" *trashinfo-formatters* + (when print-dir + (list "trash directories" *directory-formatters*)))) diff --git a/clash/parse-date.lisp b/clash/parse-date.lisp new file mode 100644 index 0000000..483d5f6 --- /dev/null +++ b/clash/parse-date.lisp @@ -0,0 +1,264 @@ +(defpackage clash/parse-date + (:documentation "Functions for parsing dates and date ranges.") + (:use #:cl) + (:export #:print-date-parsing-help + #:date-parse-error + #:date-parse-error-source + #:date-parse-error-position + #:dase-parse-error-message + #:parse-date-time + #:parse-date-range + #:timestamp-in-ranges + #:option-date-range + #:option-date-range-ranges)) + +(in-package :clash/parse-date) + +(defun print-date-parsing-help (stream) + "Print information about date parsing to STREAM." + (format stream "~ +Dates can take one of the following forms ( means THING is required, +[THING] means it is optional): + \"now\" - the current date and time + \"today\"* - midnight on the current day + \"yesterday\"* - midnight on the day before the current day + \"\" - integer seconds since midnight on January 1 1970 (UCT) + \" [Y]\"* - midnight on the Dth day of M (a month's name) of the Yth + year, or the current year if Y is omitted (any of the + whitespace between M, D, and Y can be replaced with a \"/\") +In the above table, any format which has a * next to it can optionally be +followed by a time in the format: + \":[:SECOND] [AM|PM]\" +If SECOND is omitted, it is 0. If AM or PM are omitted, the time is assumed to +be in 24-format. If the time is omitted entirely, midnight on the given date is +assumed. + +Date ranges consist of one or two dates, separated by \"..\". If just one date +is given without a separator, the pattern matches exactly that date (and +time). If two dates are given, the patten matches any time between the two dates +(inclusive of the bounds). If just a date of the form \"..\" is given, it +means \"any time after START\". Likewise, any date of the form \"..\" means +\"anytime before END\". + +Dates are supplied to commands that support then via the -R or --date-range +flags. These flags can be given any number of times. Any item which matches at +least one range given will match (that is, the union of all given dates).~%")) + +(define-condition date-parse-error (error) + ((source :accessor date-parse-error-source + :type string + :initarg :source + :documentation "The string that failed to parse.") + (pos :accessor date-parse-error-position + :type (or null integer) + :initarg :position + :initform nil + :documentation "The position of the error, or nil.") + (message :accessor date-parse-error-message + :type string + :initarg :message + :documentation "A message describing the error.")) + (:report (lambda (condition stream) + (format + stream "Failed to parse date ~S~@[ at position ~A~]: ~A" + (date-parse-error-source condition) + (date-parse-error-position condition) + (date-parse-error-message condition)))) + (:documentation "A condition representing a failure in parsing a date range.")) + +(defparameter *month-conversion-table* + '((1 "january" "jan") + (2 "february" "feb") + (3 "march" "mar") + (4 "april" "apr") + (5 "may") + (6 "june" "jun") + (7 "july" "jly" "jul") + (8 "august" "aug") + (9 "september" "sep") + (10 "october" "oct") + (11 "november" "nov") + (12 "december" "dec"))) + +(defun parse-month-string (str) + (loop for (num . text) in *month-conversion-table* + when (member str text :test 'equalp) + do (return num))) + +(defun add-time-registers (source stamp registers) + (destructuring-bind (hour minute second am-pm) (last registers 4) + (local-time:adjust-timestamp stamp + (offset :sec (parse-integer (or second "0"))) + (offset :minute (parse-integer (or minute "0"))) + (offset :hour + (if (not hour) + 0 + (cond + ((or (not am-pm) (equalp am-pm "am")) (parse-integer hour)) + ((equalp am-pm "pm") (+ (parse-integer hour) 12)) + (t (error 'date-parse-error + :source source + :message + (format nil "excpected \"AM\"/\"PM\", got: ~A" + am-pm))))))))) + +(defun current-year () + "Return the current year." + (local-time:timestamp-year (local-time:now))) + +(defun local-today () + "Return a timestamp representing the midnight today in local-time." + (local-time:adjust-timestamp! (local-time:now) + (set :hour 0) + (set :minute 0) + (set :sec 0) + (set :nsec 0))) + +(defparameter *date-parse-formats* + (let ((time-regexp + (format nil "(?:\\s|$)(?:\\s*([0-9]{1,2}):([0-9]{1,2})~ + (?::([0-9]{1,2}))?(?:\\s*(AM|PM))?)?")) + out) + (flet ((def (regexp func) + (push (cons (cl-ppcre:create-scanner + (format nil "~A~A" regexp time-regexp) + :extended-mode t :case-insensitive-mode t + :multi-line-mode t) + func) + out)) + (def-no-time (regexp func) + (push (cons (cl-ppcre:create-scanner regexp + :extended-mode t :case-insensitive-mode t + :multi-line-mode t) + func) + out))) + (def-no-time "^$" + (lambda (source registers) + (declare (ignore source registers)) + (local-time:now))) + (def-no-time "[0-9]+" + (lambda (source registers) + (declare (ignore registers)) + (local-time:unix-to-timestamp (parse-integer source)))) + (def-no-time "now" + (lambda (source registers) + (declare (ignore source registers)) + (local-time:now))) + (def "today" + (lambda (source registers) + (add-time-registers source + (local-today) + registers))) + (def "yesterday" + (lambda (source registers) + (add-time-registers source + (local-time:adjust-timestamp! (local-today) + (offset :day -1)) + registers))) + ;; 2025/10/23 3:00 pm + (def "([0-9]+)(?:\\s+|/)([0-9]{1,2})(?:\\s+|/)([0-9]{1,2})" + (lambda (source registers) + (destructuring-bind (year month day &rest ignore) registers + (declare (ignore ignore)) + (add-time-registers source + (local-time:encode-timestamp + 0 0 0 0 + (parse-integer day) + (parse-integer month) + (parse-integer year)) + registers)))) + ;; Oct 10/23 3:00 PM + (def "([A-Za-z]+)(?:\\s+|/)([0-9]{1,2})(?:(?:\\s+|/)([0-9]+))?" + (lambda (source registers) + (destructuring-bind (month-str day year &rest ignore) + registers + (declare (ignore ignore)) + (let ((month (parse-month-string month-str))) + (unless month + (error 'date-parse-error + :source source + :message (format nil "unknown month: ~S" month-str))) + (add-time-registers source + (local-time:encode-timestamp + 0 0 0 0 + (parse-integer day) + month + (if year + (parse-integer year) + (current-year))) + registers)))))))) + +(defun parse-date-time (string) + "Parse date and time from STRING." + (dolist (entry *date-parse-formats*) + (destructuring-bind (scanner . func) entry + (multiple-value-bind (start end reg-starts reg-ends) + (cl-ppcre:scan scanner string) + (when (and (eql start 0) + (eql end (length string))) + (return-from parse-date-time + (funcall func + string + (loop for s across reg-starts + for e across reg-ends + when (and s e) + collect (subseq string s e) + else + collect nil)))))))) + +(defun parse-date-range (string) + "Parse a date range from STRING." + (let ((sep (search ".." string))) + (when (not sep) + (error 'date-parse-error + :source string + :message "expected \"..\" to separate start and end date")) + (let ((second-sep (search ".." string :start2 (1+ sep)))) + (when second-sep + (error 'date-parse-error :source string + :position second-sep + :message "multiple \"..\" found"))) + (macrolet ((trim (str) + `(string-trim '(#\Tab #\Space #\Newline) ,str))) + (cons (parse-date-time (trim (subseq string 0 sep))) + (parse-date-time (trim (subseq string (+ sep 2)))))))) + +(defun timestamp-in-ranges (stamp ranges) + "Return non-nil if STAMP is in one of RANGES." + (some (lambda (range) + (destructuring-bind (start . end) range + (when (local-time:timestamp> start end) + (rotatef start end)) + (and (local-time:timestamp>= stamp start) + (local-time:timestamp<= stamp end)))) + ranges)) + +(defclass option-multi-parsed (clingon:option) + ((parser :accessor option-multi-parsed-parser + :initarg :parser + :type (function (string) t) + :documentation "The function that parses the passed value.") + (values :accessor option-multi-parsed-values + :initform nil + :type list + :documentation "The list of parsed values passed by the user.")) + (:default-initargs :parameter "VALUE") + (:documentation "An option type that parses each value passed by the user.")) + +(defmethod clingon:derive-option-value ((option option-multi-parsed) arg &key) + (with-slots (parser values) option + (push (funcall parser arg) values))) + +(defmethod clingon:finalize-option ((option option-multi-parsed) &key) + (with-slots (values) option + (setq values (nreverse values)))) + +(defmethod clingon:make-option ((kind (eql :multi-parsed)) &rest args) + (apply #'make-instance 'option-multi-parsed args)) + +(defclass option-date-range (option-multi-parsed) + () + (:default-initargs :parameter "RANGE" :parser #'parse-date-range)) + +(defmethod clingon:make-option ((kind (eql :date-range)) &rest args) + (apply #'make-instance 'option-date-range args))