Finish all features (for now)
This commit is contained in:
10
README.md
10
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.
|
||||
|
||||
25
cl-xdg-trash/README.md
Normal file
25
cl-xdg-trash/README.md
Normal file
@ -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`.
|
||||
@ -5,7 +5,7 @@
|
||||
:maintainer "Alexander Rosenberg <zanderpkg@pm.me>"
|
||||
: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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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)))
|
||||
|
||||
@ -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,9 +224,11 @@ trashed file NAME in TRASH-DIRECTORY."
|
||||
:context "" :source-file source-file
|
||||
:message
|
||||
"End-of-file without both \"Path\" and \"DeletionDate\"")
|
||||
(return (make-instance 'trashinfo
|
||||
(return (make-instance
|
||||
'trashinfo
|
||||
:deletion-date deletion-date
|
||||
:original-path path :name name
|
||||
:original-path (directory-as-file-pathname path)
|
||||
:name name
|
||||
:trash-directory trash-directory)))))
|
||||
|
||||
(declaim (ftype (function ((or pathname string) string) trashinfo)))
|
||||
@ -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,15 +315,19 @@ 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)))
|
||||
(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 trash-directory
|
||||
:trash-directory
|
||||
(ensure-nonwild-pathname trash-directory
|
||||
:ensure-directory t)
|
||||
:deletion-date deletion-date)))
|
||||
(format-trashinfo trashinfo stream)
|
||||
trashinfo))
|
||||
|
||||
@ -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."
|
||||
|
||||
@ -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
|
||||
|
||||
19
clash/README.md
Normal file
19
clash/README.md
Normal file
@ -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.
|
||||
@ -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")))
|
||||
|
||||
1094
clash/clash.lisp
1094
clash/clash.lisp
File diff suppressed because it is too large
Load Diff
384
clash/format.lisp
Normal file
384
clash/format.lisp
Normal file
@ -0,0 +1,384 @@
|
||||
(defpackage clash/format
|
||||
(:documentation "Formatters for trashinfos and trash directories.")
|
||||
(:import-from #:cl-xdg-trash/mountpoints
|
||||
#:file-or-dir-namestring)
|
||||
(:import-from #:cl-xdg-trash/directorysizes
|
||||
#:trashed-file-size)
|
||||
(:import-from #:cl-xdg-trash/trashinfo
|
||||
#:trashinfo-trash-directory
|
||||
#:trashinfo-name
|
||||
#:trashinfo-deletion-date
|
||||
#:trashinfo-original-path
|
||||
#:trashinfo-info-file
|
||||
#:trashinfo-trashed-file)
|
||||
(:use #:cl)
|
||||
(:export #:trashinfo-size
|
||||
#:format-size
|
||||
#:parse-format-string
|
||||
#:option-format-string
|
||||
#:option-format-string-directives
|
||||
#:format-object
|
||||
#:format-list
|
||||
#:print-format-info
|
||||
#:*trashinfo-formatters*
|
||||
#:*directory-formatters*
|
||||
#:print-clash-format-info
|
||||
#:*missing-file-formatters*))
|
||||
|
||||
(in-package :clash/format)
|
||||
|
||||
(defvar *trashinfo-size-cache* (make-hash-table :test #'eq)
|
||||
"Cache for trashinfo sizes.")
|
||||
|
||||
(defun trashinfo-size (trashinfo)
|
||||
"Return the size of TRASHINFO and cache it."
|
||||
(let ((res (gethash trashinfo *trashinfo-size-cache* :none)))
|
||||
(if (eq res :none)
|
||||
(setf (gethash trashinfo *trashinfo-size-cache*)
|
||||
(trashed-file-size (trashinfo-trash-directory trashinfo)
|
||||
(trashinfo-name trashinfo)))
|
||||
res)))
|
||||
|
||||
(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 finding the size 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)))))
|
||||
|
||||
(defclass format-code ()
|
||||
((name :reader format-code-name
|
||||
:type character
|
||||
:initarg :name
|
||||
:documentation "The character used to invoke this formatter.")
|
||||
(action :reader format-code-action
|
||||
:type (function (stream t) t)
|
||||
:initarg :action
|
||||
:documentation "The function to call to use this formatter.")
|
||||
(padder :reader format-code-padder
|
||||
:type (or null
|
||||
(function (stream (member nil :left :right) string t) t))
|
||||
:initarg :padder
|
||||
:initform nil
|
||||
:documentation
|
||||
"An optional function to pad the result of the action.")
|
||||
(doc :reader format-code-doc
|
||||
:type (or null string)
|
||||
:initarg :doc
|
||||
:initform nil
|
||||
:documentation "The documentation for this format code."))
|
||||
(:documentation "A single format escape sequence."))
|
||||
|
||||
(defmethod print-object ((obj format-code) stream)
|
||||
(print-unreadable-object (obj stream :type t :identity t)
|
||||
(with-slots (name padder) obj
|
||||
(format stream "%~A~@[ (supports padding)~]" name padder))))
|
||||
|
||||
(defun make-format-code (&rest args)
|
||||
(apply #'make-instance 'format-code args))
|
||||
|
||||
(defun parse-format-string (format-string directives)
|
||||
"Parse 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* ((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*))))
|
||||
264
clash/parse-date.lisp
Normal file
264
clash/parse-date.lisp
Normal file
@ -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 (<THING> 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
|
||||
\"<NUMBER>\" - integer seconds since midnight on January 1 1970 (UCT)
|
||||
\"<M> <D> [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:
|
||||
\"<HOUR>:<MINUTE>[: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 \"<START>..\" is given, it
|
||||
means \"any time after START\". Likewise, any date of the form \"..<END>\" 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))
|
||||
Reference in New Issue
Block a user