|
|
@@ -29,12 +29,14 @@
|
|
|
(or (and (zerop (mod year 4))
|
|
|
(not (zerop (mod year 100))))
|
|
|
(zerop (mod year 400))))
|
|
|
+ (month-days (month year)
|
|
|
+ (case month
|
|
|
+ (2 (if (leapp year) 29 28))
|
|
|
+ ((1 3 5 7 8 10 12) 31)
|
|
|
+ (otherwise 30)))
|
|
|
(clamp-day-rule (day-rule month year)
|
|
|
(destructuring-bind (lst &optional (min 0) max (step 1)) day-rule
|
|
|
- (let ((max-day (case month
|
|
|
- (2 (if (leapp year) 29 28))
|
|
|
- ((1 3 5 7 8 10 12) 31)
|
|
|
- (otherwise 30))))
|
|
|
+ (let ((max-day (month-days month year)))
|
|
|
(if (consp lst)
|
|
|
(list (remove-duplicates (mapcar (lambda (d) (min d max-day)) lst)))
|
|
|
(list nil (min min) (when max (min max max-day)) step)))))
|
|
|
@@ -61,15 +63,17 @@
|
|
|
(t (values nv nil)))))))
|
|
|
(add (v of)
|
|
|
(funcall (if dir #'+ #'-) v (if of 1 0)))
|
|
|
- (reset-rule (rule)
|
|
|
- (destructuring-bind (lst &optional (min 0) max (step 1)) rule
|
|
|
- (if (consp lst)
|
|
|
- (car (if dir lst (last lst)))
|
|
|
- (if dir min
|
|
|
- (let ((m (mod (- max min) step)))
|
|
|
- (- max (if (zerop m) 0 m))))))))
|
|
|
- (multiple-value-bind (second minute hour day month year dow dst-p tz) (decode-universal-time universal-time)
|
|
|
- (declare (ignore second minute hour dow dst-p tz))
|
|
|
+ (reset-rule (rule def-min def-max)
|
|
|
+ (destructuring-bind (lst &optional min max (step 1)) rule
|
|
|
+ (let ((min (or min def-min))
|
|
|
+ (max (or max def-max)))
|
|
|
+ (if (consp lst)
|
|
|
+ (car (if dir lst (last lst)))
|
|
|
+ (if dir min
|
|
|
+ (let ((m (mod (- max min) step)))
|
|
|
+ (- max (if (zerop m) 0 m)))))))))
|
|
|
+ (multiple-value-bind (second minute hour day month year) (decode-universal-time universal-time)
|
|
|
+ (declare (ignore second minute hour))
|
|
|
(destructuring-bind (&optional (day-rule '(nil 1 31)) (month-rule '(nil 1 12)) (year-rule '(nil 1900)))
|
|
|
schedule
|
|
|
(multiple-value-bind (next-day of-day) (next (add day (not dir))
|
|
|
@@ -77,11 +81,12 @@
|
|
|
(multiple-value-bind (next-month of-month) (next (add month of-day) month-rule)
|
|
|
(multiple-value-bind (next-year of-year) (next (add year of-month) year-rule)
|
|
|
(unless of-year
|
|
|
- (let ((next-month (if (= next-year year) next-month (reset-rule month-rule))))
|
|
|
+ (let ((next-month (if (= next-year year) next-month (reset-rule month-rule 1 12))))
|
|
|
(encode-universal-time
|
|
|
0 0 0
|
|
|
(if (and (= next-month month) (= next-year year)) next-day
|
|
|
- (reset-rule (clamp-day-rule day-rule next-month next-year)))
|
|
|
+ (reset-rule (clamp-day-rule day-rule next-month next-year) 1
|
|
|
+ (month-days next-month next-year)))
|
|
|
next-month
|
|
|
next-year))))))))))
|
|
|
|
