Finish all features (for now)
This commit is contained in:
@ -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")))
|
||||
|
||||
1180
clash/clash.lisp
1180
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