Broken all functionality out into separate modules.

1 files changed, 356 insertions, 0 deletions

diff --git a/vixie-time.scm b/vixie-time.scm
new file mode 100644
index 0000000..164a8de
--- /dev/null
+++ b/vixie-time.scm
@@ -0,0 +1,356 @@
+;;   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)
+               (display "Error: Bad Vixie-style time specification.\n")
+               (primitive-exit 9))
+              ((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]. 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)))
+         (time-spec-list
+          (map-in-order (lambda (x) (vector (parse-vixie-element
+                                              (list-ref tokens (vector-ref x 0))
+                                            (vector-ref x 1)
+                                            (vector-ref x 2))
+                                            (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]