civodul pushed a commit to branch devel
in repository shepherd.
commit 8f455e539e23d6b0838689c56b781704f7791a98
Author: Ludovic Courtès <l...@gnu.org>
AuthorDate: Sat Aug 17 00:33:05 2024 +0200
timer: Recurse when the days/weekdays intersection is empty.
* modules/shepherd/service/timer.scm (fit-day): Recurse on the next
month when DAYS* is empty.
* tests/services/timer-events.scm ("next-calendar-event, every Friday
13th"):
New test.
---
modules/shepherd/service/timer.scm | 34 ++++++++++++++++++++--------------
tests/services/timer-events.scm | 19 +++++++++++++++++++
2 files changed, 39 insertions(+), 14 deletions(-)
diff --git a/modules/shepherd/service/timer.scm
b/modules/shepherd/service/timer.scm
index eca252d..2b48e8a 100644
--- a/modules/shepherd/service/timer.scm
+++ b/modules/shepherd/service/timer.scm
@@ -245,20 +245,26 @@ is closer to @var{current} than its second argument. The
distance to
(date-month date)
(date-year date)))))
- (let loop ((candidates (sort days*
- (sooner (date-day date)
- (days-in-month (date-month date)
- (date-year date))))))
- (match candidates
- ((first . rest)
- (if (and (not future?)
- (= first (date-day date))
- (> (date-hour date) 0))
- (loop rest)
- (if (>= first (date-day date))
- (set-date-day date first)
- (let ((date (increment-month (set-date-day date 1))))
- (fit-day date days weekdays #t))))))))
+ (if (and (null? days*)
+ (not (null? days)) (not (null? weekdays)))
+ ;; DAYS* is empty because the DAYS/WEEKDAYS intersection is empty--e.g.,
+ ;; no Friday 13th this month. Try the next month.
+ (let ((date (increment-month (set-date-day date 1))))
+ (fit-day date days weekdays #t))
+ (let loop ((candidates (sort days*
+ (sooner (date-day date)
+ (days-in-month (date-month date)
+ (date-year date))))))
+ (match candidates
+ ((first . rest)
+ (if (and (not future?)
+ (= first (date-day date))
+ (> (date-hour date) 0))
+ (loop rest)
+ (if (>= first (date-day date))
+ (set-date-day date first)
+ (let ((date (increment-month (set-date-day date 1))))
+ (fit-day date days weekdays #t)))))))))
(define (fit-hour date hours)
(let loop ((candidates (sort hours
diff --git a/tests/services/timer-events.scm b/tests/services/timer-events.scm
index dfe774c..8da8f00 100644
--- a/tests/services/timer-events.scm
+++ b/tests/services/timer-events.scm
@@ -143,6 +143,25 @@
(loop date (+ 1 n) (cons date result)))
(reverse result)))))
+(test-equal "next-calendar-event, every Friday 13th"
+ (list (make-date 0 0 14 17 13 09 2024 3600)
+ (make-date 0 0 14 17 13 12 2024 3600)
+ (make-date 0 0 14 17 13 06 2025 3600)
+ (make-date 0 0 14 17 13 02 2026 3600)
+ (make-date 0 0 14 17 13 03 2026 3600))
+ (let ((event (calendar-event #:hours '(17)
+ #:minutes '(14)
+ #:days-of-week '(friday)
+ #:days-of-month '(13))))
+ (let loop ((date (make-date 123456789 42 09 12
+ 01 08 2024 3600))
+ (n 0)
+ (result '()))
+ (if (< n 5)
+ (let ((date (next-calendar-event event date)))
+ (loop date (+ 1 n) (cons date result)))
+ (reverse result)))))
+
(let-syntax ((test-cron (syntax-rules ()
((_ str calendar)
(test-equal (string-append
