1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
|
;; Copyright (C) 2003 Dale Mellor
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;; USA.
(define-module (mcron vixie-time)
#:export (parse-vixie-time)
#:use-module (mcron job-specifier))
(use-modules (srfi srfi-1) (srfi srfi-13) (srfi srfi-14)
(ice-9 regex))
;; In Vixie-style time specifications three-letter symbols are allowed to stand
;; for the numbers corresponding to months and days of the week. We deal with
;; this by making a textual substitution early on in the processing of the
;; strings.
;;
;; We start by defining, once and for all, a list of cons cells consisting of
;; regexps which will match the symbols - which allow an arbitrary number of
;; other letters to appear after them (so that the user can optionally complete
;; the month and day names; this is an extension of Vixie) - and the value which
;; is to replace the symbol.
;;
;; The procedure then takes a string, and then for each symbol in the
;; parse-symbols list attempts to locate an instance and replace it with an
;; ASCII representation of the value it stands for. The procedure returns the
;; modified string. (Note that each symbol can appear only once, which meets the
;; Vixie specifications technically but still allows silly users to mess things
;; up).
(define parse-symbols
(map (lambda (symbol-cell)
(cons (make-regexp (string-append (car symbol-cell) "[[:alpha:]]*")
regexp/icase)
(cdr symbol-cell)))
'(("jan" . "0") ("feb" . "1") ("mar" . "2") ("apr" . "3")
("may" . "4") ("jun" . "5") ("jul" . "6") ("aug" . "7")
("sep" . "8") ("oct" . "9") ("nov" . "10") ("dec" . "11")
("sun" . "0") ("mon" . "1") ("tue" . "2") ("wed" . "3")
("thu" . "4") ("fri" . "5") ("sat" . "6") )))
(define (vixie-substitute-parse-symbols string)
(for-each (lambda (symbol-cell)
(let ((match (regexp-exec (car symbol-cell) string)))
(if match
(set! string (string-append (match:prefix match)
(cdr symbol-cell)
(match:suffix match))))))
parse-symbols)
string)
;; A Vixie time specification is made up of a space-separated list of elements,
;; and the elements consist of a comma-separated list of subelements. The
;; procedure below takes a string holding a subelement, which should have no
;; spaces or symbols (see above) in it, and returns a list of all values which
;; that subelement indicates. There are five distinct cases which must be dealt
;; with: [1] a single '*' which returns a list of all values; [2] a '*' followed
;; by a step specifier; [3] a range and step specifier; [4] a range; and [5] a
;; single number.
;;
;; To perform the computation required for the '*' cases, we need to pass the
;; limit of the allowable range for this subelement as the third argument. As
;; days of the month start at 1 while all the other time components start at 0,
;; we must pass the base of the range to deal with this case also.
(define parse-vixie-subelement-regexp
(make-regexp "^([[:digit:]]+)(-([[:digit:]]+)(/([[:digit:]]+))?)?$"))
(define (parse-vixie-subelement string base limit)
(if (char=? (string-ref string 0) #\*)
(range base limit (if (> (string-length string) 1)
(string->number (substring string 2)) ;; [2]
1)) ;; [1]
(let ((match (regexp-exec parse-vixie-subelement-regexp string)))
(cond ((not match)
(throw 'mcron-error 9
"Bad Vixie-style time specification."))
((match:substring match 5)
(range (string->number (match:substring match 1))
(+ 1 (string->number (match:substring match 3)))
(string->number (match:substring match 5)))) ;; [3]
((match:substring match 3)
(range (string->number (match:substring match 1))
(+ 1 (string->number (match:substring match 3))))) ;; [4]
(else
(list (string->number (match:substring match 1)))))))) ;; [5]
;; A Vixie element contains the entire specification, without spaces or symbols,
;; of the acceptable values for one of the time components (minutes, hours,
;; days, months, week days). Here we break the comma-separated list into
;; subelements, and process each with the procedure above. The return value is a
;; list of all the valid values of all the subcomponents.
;;
;; The second and third arguments are the base and upper limit on the values
;; that can be accepted for this time element.
;;
;; The effect of the 'apply append' is to merge a list of lists into a single
;; list.
(define (parse-vixie-element string base limit)
(apply append
(map (lambda (sub-element)
(parse-vixie-subelement sub-element base limit))
(string-tokenize string (char-set-complement (char-set #\,))))))
;; Consider there are two lists, one of days in the month, the other of days in
;; the week. This procedure returns an augmented list of days in the month with
;; weekdays accounted for.
(define (interpolate-weekdays mday-list wday-list month year)
(let ((t (localtime 0)))
(set-tm:mday t 1)
(set-tm:mon t month)
(set-tm:year t year)
(let ((first-day (tm:wday (cdr (mktime t)))))
(apply append
mday-list
(map (lambda (wday)
(let ((first (- wday first-day)))
(if (< first 0) (set! first (+ first 7)))
(range (+ 1 first) 32 7)))
wday-list)))))
;; Return the number of days in a month. Fix up a tm object for the zero'th day
;; of the next month, rationalize the object and extract the day.
(define (days-in-month month year)
(let ((t (localtime 0))) (set-tm:mday t 0)
(set-tm:mon t (+ month 1))
(set-tm:year t year)
(tm:mday (cdr (mktime t)))))
;; We will be working with a list of time-spec's, one for each element of a time
;; specification (minute, hour, ...). Each time-spec holds three pieces of
;; information: a list of acceptable values for this time component, a procedure
;; to get the component from a tm object, and a procedure to set the component
;; in a tm object.
(define (time-spec:list time-spec) (vector-ref time-spec 0))
(define (time-spec:getter time-spec) (vector-ref time-spec 1))
(define (time-spec:setter time-spec) (vector-ref time-spec 2))
;; This procedure modifies the time tm object by setting the component referred
;; to by the time-spec object to its next acceptable value. If this value is not
;; greater than the original (because we have wrapped around the top of the
;; acceptable values list), then the function returns #t, otherwise it returns
;; #f. Thus, if the return value is true then it will be necessary for the
;; caller to increment the next coarser time component as well.
;;
;; The first part of the let block is a concession to humanity; the procedure is
;; simply unreadable without all of these aliases.
(define (increment-time-component time time-spec)
(let* ((time-list (time-spec:list time-spec))
(getter (time-spec:getter time-spec))
(setter (time-spec:setter time-spec))
(next-best (find-best-next (getter time) time-list))
(wrap-around (eqv? (cdr next-best) 9999)))
(setter time ((if wrap-around car cdr) next-best))
wrap-around))
;; There now follows a set of procedures for adjusting an element of time,
;; i.e. taking it to the next acceptable value. In each case, the head of the
;; time-spec-list is expected to correspond to the component of time in
;; question. If the adjusted value wraps around its allowed range, then the next
;; biggest element of time must be adjusted, and so on.
;; There is no specification allowed for the year component of
;; time. Therefore, if we have to make an adjustment (presumably because a
;; monthly adjustment has wrapped around the top of its range) we can simply
;; go to the next year.
(define (nudge-year! time)
(set-tm:year time (+ (tm:year time) 1)))
;; We nudge the month by finding the next allowable value, and if it wraps
;; around we also nudge the year. The time-spec-list will have time-spec
;; objects for month and weekday.
(define (nudge-month! time time-spec-list)
(and (increment-time-component time (car time-spec-list))
(nudge-year! time)))
;; Try to increment the day component of the time according to the combination
;; of the mday-list and the wday-list. If this wraps around the range, or if
;; this falls outside the current month (31st February, for example), then
;; bump the month, set the day to zero, and recurse on this procedure to find
;; the next day in the new month.
;;
;; The time-spec-list will have time-spec entries for mday, month, and
;; weekday.
(define (nudge-day! time time-spec-list)
(if (or (increment-time-component
time
(vector
(interpolate-weekdays (time-spec:list (car time-spec-list))
(time-spec:list (caddr time-spec-list))
(tm:mon time)
(tm:year time))
tm:mday
set-tm:mday))
(> (tm:mday time) (days-in-month (tm:mon time) (tm:year time))))
(begin
(nudge-month! time (cdr time-spec-list))
(set-tm:mday time 0)
(nudge-day! time time-spec-list))))
;; The hour is bumped to the next accceptable value, and the day is bumped if
;; the hour wraps around.
;;
;; The time-spec-list holds specifications for hour, mday, month and weekday.
(define (nudge-hour! time time-spec-list)
(and (increment-time-component time (car time-spec-list))
(nudge-day! time (cdr time-spec-list))))
;; The minute is bumped to the next accceptable value, and the hour is bumped
;; if the minute wraps around.
;;
;; The time-spec-list holds specifications for minute, hour, day-date, month
;; and weekday.
(define (nudge-min! time time-spec-list)
(and (increment-time-component time (car time-spec-list))
(nudge-hour! time (cdr time-spec-list))))
;; This is a procedure which returns a procedure which computes the next time a
;; command should run after the current time, based on the information in the
;; Vixie-style time specification.
;;
;; We start by computing a list of time-spec objects (described above) for the
;; minute, hour, date, month, year and weekday components of the overall time
;; specification [1]. Special care is taken to produce proper values for
;; fields 2 and 4: according to Vixie specification "If both fields are
;; restricted (ie, aren't *), the command will be run when _either_ field
;; matches the current time." This implies that if one of these fields is *,
;; while the other is not, its value should be '() [0], otherwise
;; interpolate-weekdays below will produce incorrect results.
;; When we create the return procedure, it is this list to
;; which references to a time-spec-list will be bound. It will be used by the
;; returned procedure [3] to compute the next time a function should run. Any
;; 7's in the weekday component of the list (the last one) are folded into 0's
;; (both values represent sunday) [2]. Any 0's in the month-day component of the
;; list are removed (this allows a solitary zero to be used to indicate that
;; jobs should only run on certain days of the _week_) [2.1].
;;
;; The returned procedure itself:-
;;
;; Starts by obtaining the current broken-down time [4], and fixing it to
;; ensure that it is an acceptable value, as follows. Each component from the
;; biggest down is checked for acceptability, and if it is not acceptable it
;; is bumped to the next acceptable value (this may cause higher components to
;; also be bumped if there is range wrap-around) and all the lower components
;; are set to -1 so that it can successfully be bumped up to zero if this is
;; an allowed value. The -1 value will be bumped up subsequently to an allowed
;; value [5].
;;
;; Once it has been asserted that the current time is acceptable, or has been
;; adjusted to one minute before the next acceptable time, the minute
;; component is then bumped to the next acceptable time, which may ripple
;; through the higher components if necessary [6]. We now have the next time
;; the command needs to run.
;;
;; The new time is then converted back into a UNIX time and returned [7].
(define (parse-vixie-time string)
(let ((tokens (string-tokenize (vixie-substitute-parse-symbols string))))
(cond
((> (length tokens) 5)
(throw 'mcron-error 9
"Too many fields in Vixie-style time specification"))
((< (length tokens) 5)
(throw 'mcron-error 9
"Not enough fields in Vixie-style time specification")))
(let ((time-spec-list
(map-in-order (lambda (x) (vector
(let* ((n (vector-ref x 0))
(tok (list-ref tokens n)))
(cond
((and (= n 4)
(string=? tok "*")
(not (string=?
(list-ref tokens 2) "*")))
'())
((and (= n 2)
(string=? tok "*")
(not (string=?
(list-ref tokens 4) "*")))
'())
(else
(parse-vixie-element
tok
(vector-ref x 1)
(vector-ref x 2))))) ; [0]
(vector-ref x 3)
(vector-ref x 4)))
;; token range-top+1 getter setter
`( #( 0 0 60 ,tm:min ,set-tm:min )
#( 1 0 24 ,tm:hour ,set-tm:hour )
#( 2 1 32 ,tm:mday ,set-tm:mday )
#( 3 0 12 ,tm:mon ,set-tm:mon )
#( 4 0 7 ,tm:wday ,set-tm:wday ))))) ;; [1]
(vector-set! (car (last-pair time-spec-list))
0
(map (lambda (time-spec)
(if (eqv? time-spec 7) 0 time-spec))
(vector-ref (car (last-pair time-spec-list)) 0))) ;; [2]
(vector-set! (caddr time-spec-list)
0
(remove (lambda (day) (eqv? day 0))
(vector-ref (caddr time-spec-list) 0))) ;; [2.1]
(lambda (current-time) ;; [3]
(let ((time (localtime current-time))) ;; [4]
(if (not (member (tm:mon time)
(time-spec:list (cadddr time-spec-list))))
(begin
(nudge-month! time (cdddr time-spec-list))
(set-tm:mday time 0)))
(if (or (eqv? (tm:mday time) 0)
(not (member (tm:mday time)
(interpolate-weekdays
(time-spec:list (caddr time-spec-list))
(time-spec:list (caddr (cddr time-spec-list)))
(tm:mon time)
(tm:year time)))))
(begin
(nudge-day! time (cddr time-spec-list))
(set-tm:hour time -1)))
(if (not (member (tm:hour time)
(time-spec:list (cadr time-spec-list))))
(begin
(nudge-hour! time (cdr time-spec-list))
(set-tm:min time -1))) ;; [5]
(set-tm:sec time 0)
(nudge-min! time time-spec-list) ;; [6]
(car (mktime time))))))) ;; [7]
|
