;======================================================================
;; Copyright 2006-2016, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest 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 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest 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 Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================
;; NOTE: This is the db module, long term it will replace db.scm.
;; WARN: This module conflicts with db.scm as it uses sql-de-lite
(declare (unit mtcommon))
(module mtcommon
(
get-create-writeable-dir
print-error
print-info
log-event
debug-setup
debug-mode
check-verbosity
calc-verbosity
;; pkts stuff
load-pkts-to-db
get-pkt-alists
with-queue-db
get-pkts-dirs
get-pkt-times
;; unix stuff
get-cached-info
write-cached-info
get-normalized-cpu-load
bash-glob
get-youngest
;; time
hms-string->seconds
seconds->hr-min-sec
seconds->time-string
seconds->work-week/day-time
seconds->work-week/day
seconds->year-work-week/day
seconds->year-work-week/day-time
seconds->year-week/day-time
seconds->quarter
date-time->seconds
find-start-mark-and-mark-delta
expand-cron-slash
cron-expand
cron-event
extended-cron
;; other
get-param-mapping
;; debug
debug-print
print-error
print-info
)
(import scheme chicken data-structures extras posix ports)
(use (prefix sql-de-lite sql:) posix typed-records format srfi-1 srfi-69 pkts regex (prefix dbi dbi:) regex-case matchable)
(defstruct ctrldat
(port (current-error-port))
(verbosity 1)
(vcache (make-hash-table))
(logging #f) ;; keep the flag and the db handle separate to enable overriding
(logdb #f) ;; might need to make this a stack of handles for threaded access
(toppath #f) ;;
)
(define *log* (make-ctrldat))
;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
(define (calc-verbosity vstr args)
(or (hash-table-ref/default (ctrldat-vcache *log*) vstr #f)
(let ((res (cond
((number? vstr) vstr)
((not (string? vstr)) 1)
;; ((string-match "^\\s*$" vstr) 1)
(vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
(cond
((> (length debugvals) 1) debugvals)
((> (length debugvals) 0)(car debugvals))
(else 1))))
((hash-table-exists? args "-v") 2)
((hash-table-exists? args "-q") 0)
(else 1))))
(hash-table-set! (ctrldat-vcache *log*) vstr res)
res)))
;; check verbosity, #t is ok
(define (check-verbosity verbosity vstr)
(if (not (or (number? verbosity)
(list? verbosity)))
(begin
(print "ERROR: Invalid debug value \"" vstr "\"")
#f)
#t))
(define (debug-mode n)
(let* ((verbosity (ctrldat-verbosity *log*)))
(cond
((and (number? verbosity) ;; number number
(number? n))
(<= n verbosity))
((and (list? verbosity) ;; list number
(number? n))
(member n verbosity))
((and (list? verbosity) ;; list list
(list? n))
(not (null? (lset-intersection! eq? verbosity n))))
((and (number? verbosity)
(list? n))
(member verbosity n)))))
(define (debug-setup args)
(let* ((debugstr (or (hash-table-ref/default args "-debug" #f)
(get-environment-variable "MT_DEBUG_MODE")))
(verbosity (calc-verbosity debugstr args)))
;; if we were handed a bad verbosity rule then we will override it with 1 and continue
(if (not (check-verbosity verbosity debugstr))
(set! verbosity 1))
(ctrldat-verbosity-set! *log* verbosity)
(if (or (hash-table-exists? args "-debug")
(not (get-environment-variable "MT_DEBUG_MODE")))
(setenv "MT_DEBUG_MODE" (if (list? verbosity)
(string-intersperse (map conc verbosity) ",")
(conc verbosity))))))
(define (debug-print n e . params)
(if (debug-mode n)
(with-output-to-port (or e (current-error-port))
(lambda ()
(if (ctrldat-logging *log*)
(log-event (apply conc params))
(apply print params)
)))))
;; more betterer implementation above?
;; (define (print-info n e . params)
;; (apply debug-print n e "INFO: " params))
;; ;; Brandon's debug printer shortcut (indulge me :)
;; (define *BB-process-starttime* (current-milliseconds))
;; (define (BB> . in-args)
;; (let* ((stack (get-call-chain))
;; (location "??"))
;; (for-each
;; (lambda (frame)
;; (let* ((this-loc (vector-ref frame 0))
;; (temp (string-split (->string this-loc) " "))
;; (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
;; (if (equal? this-func "BB>")
;; (set! location this-loc))))
;; stack)
;; (let* ((color-on "\x1b[1m")
;; (color-off "\x1b[0m")
;; (dp-args
;; (append
;; (list 0 *default-log-port*
;; (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") )
;; in-args)))
;; (apply debug:print dp-args))))
;;
;; (define *BBpp_custom_expanders_list* (make-hash-table))
;;
;;
;;
;; ;; register hash tables with BBpp.
;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
;; (cons hash-table? hash-table->alist))
;;
;; ;; test name converter
;; (define (BBpp_custom_converter arg)
;; (let ((res #f))
;; (for-each
;; (lambda (custom-type-name)
;; (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
;; (custom-type-test (car custom-type-info))
;; (custom-type-converter (cdr custom-type-info)))
;; (when (and (not res) (custom-type-test arg))
;; (set! res (custom-type-converter arg)))))
;; (hash-table-keys *BBpp_custom_expanders_list*))
;; (if res (BBpp_ res) arg)))
;;
;; (define (BBpp_ arg)
;; (cond
;; ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
;; ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
;; ((hash-table? arg)
;; (let ((al (hash-table->alist arg)))
;; (BBpp_ (cons HASH_TABLE: al))))
;; ((null? arg) '())
;; ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;; ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;; (else (BBpp_custom_converter arg))))
;;
;; ;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp
;; (define (BBpp arg)
;; (pp (BBpp_ arg)))
;;
;; ;(use define-macro)
;; (define-syntax inspect
;; (syntax-rules ()
;; [(_ x)
;; ;; (with-output-to-port (current-error-port)
;; (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
;; ;; )
;; ]
;; [(_ x y ...) (begin (inspect x) (inspect y ...))]))
(define (print-error n e . params)
;; normal print
(if (debug-mode n)
(with-output-to-port (if (port? e) e (current-error-port))
(lambda ()
(if (ctrldat-logging *log*)
(log-event (apply conc params))
;; (apply print "pid:" (current-process-id) " " params)
(apply print "ERROR: " params)
))))
;; pass important messages to stderr
(if (and (eq? n 0)(not (eq? e (current-error-port))))
(with-output-to-port (current-error-port)
(lambda ()
(apply print "ERROR: " params)
))))
(define (print-info n e . params)
(if (debug-mode n)
(with-output-to-port (if (port? e) e (current-error-port))
(lambda ()
(if (ctrldat-logging *log*)
(let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
(log-event res))
(apply print "INFO: (" n ") " params) ;; res)
)))))
;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
(if (or (number? val)(string? val)) val ""))
;;======================================================================
;; Unix stuff
;;======================================================================
;; get values from cached info from dropping file in logs dir
;; e.g. key is host and dtype is normalized-load
;;
(define (get-cached-info logdir key dtype #!key (age 5)(log-port (current-error-port)))
(let* ((fullpath (conc logdir "/" key "-" dtype ".log")))
(if (and (file-exists? fullpath)
(file-read-access? fullpath))
(handle-exceptions
exn
#f
(debug-print 2 log-port "reading file " fullpath)
(let ((real-age (- (current-seconds)(file-change-time fullpath))))
(if (< real-age age)
(with-input-from-file fullpath read)
(begin
(debug-print 2 log-port "file " fullpath " is too old (" real-age" seconds)to trust, skipping reading it")
#f))))
(begin
(debug-print 2 log-port "not reading file " fullpath)
#f))))
(define (write-cached-info logdir key dtype dat)
(let* ((fullpath (conc logdir "/" key "-" dtype ".log")))
(handle-exceptions
exn
#f
(with-output-to-file fullpath (lambda ()(pp dat))))))
;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads
;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc.
;; keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load
;;
(define (get-normalized-cpu-load logdir remote-host)
(let ((actual-host (or remote-host (get-host-name)))) ;; #f is localhost
(or (get-cached-info logdir actual-host "normalized-load")
(let ((data (if remote-host
(with-input-from-pipe
(conc "ssh " remote-host " cat /proc/loadavg;cat /proc/cpuinfo;echo end")
read-lines)
(append
(with-input-from-file "/proc/loadavg"
read-lines)
(with-input-from-file "/proc/cpuinfo"
read-lines)
(list "end"))))
(load-rx (regexp "^([\\d\\.]+)\\s+([\\d\\.]+)\\s+([\\d\\.]+)\\s+.*$"))
(proc-rx (regexp "^processor\\s+:\\s+(\\d+)\\s*$"))
(core-rx (regexp "^core id\\s+:\\s+(\\d+)\\s*$"))
(phys-rx (regexp "^physical id\\s+:\\s+(\\d+)\\s*$"))
(max-num (lambda (p n)(max (string->number p) n))))
;; (print "data=" data)
(if (null? data) ;; something went wrong
#f
(let loop ((hed (car data))
(tal (cdr data))
(loads #f)
(proc-num 0) ;; processor includes threads
(phys-num 0) ;; physical chip on motherboard
(core-num 0)) ;; core
;; (print hed ", " loads ", " proc-num ", " phys-num ", " core-num)
(if (null? tal) ;; have all our data, calculate normalized load and return result
(let* ((act-proc (+ proc-num 1))
(act-phys (+ phys-num 1))
(act-core (+ core-num 1))
(adj-proc-load (/ (car loads) act-proc))
(adj-core-load (/ (car loads) act-core))
(result
(append (list (cons 'adj-proc-load adj-proc-load)
(cons 'adj-core-load adj-core-load))
(list (cons '1m-load (car loads))
(cons '5m-load (cadr loads))
(cons '15m-load (caddr loads)))
(list (cons 'proc act-proc)
(cons 'core act-core)
(cons 'phys act-phys)))))
(write-cached-info logdir actual-host "normalized-load" result)
result)
(regex-case
hed
(load-rx ( x l1 l5 l15 ) (loop (car tal)(cdr tal)(map string->number (list l1 l5 l15)) proc-num phys-num core-num))
(proc-rx ( x p ) (loop (car tal)(cdr tal) loads (max-num p proc-num) phys-num core-num))
(phys-rx ( x p ) (loop (car tal)(cdr tal) loads proc-num (max-num p phys-num) core-num))
(core-rx ( x c ) (loop (car tal)(cdr tal) loads proc-num phys-num (max-num c core-num)))
(else
(begin
;; (print "NO MATCH: " hed)
(loop (car tal)(cdr tal) loads proc-num phys-num core-num)))))))))))
;; use bash to expand a glob. Does NOT handle paths with spaces!
;;
(define (bash-glob instr)
(string-split
(with-input-from-pipe
(conc "/bin/bash -c \"echo " instr "\"")
read-line)))
;; return the youngest timestamp . filename
;;
(define (get-youngest glob-list)
(let ((all-files (apply append
(map (lambda (patt)
(handle-exceptions
exn
'()
(glob patt)))
glob-list))))
(fold (lambda (fname res)
(let ((last-mod (car res))
(curmod (handle-exceptions
exn
0
(file-modification-time fname))))
(if (> curmod last-mod)
(list curmod fname)
res)))
'(0 "n/a")
all-files)))
;;======================================================================
;; L O G G I N G D B
;;======================================================================
(define (open-logging-db toppath)
(let* ((dbpath (conc (if toppath (conc toppath "/") "") "logging.db")) ;; fname)
(dbexists (file-exists? dbpath))
(db (sql:open-database dbpath))
(handler (sql:busy-timeout 136000))) ;; remove argument to override
(sql:set-busy-handler! db handler)
(if (not dbexists)
(sql:exec (sql:sql db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);")))
(sql:exec (sql:sql db "PRAGMA synchronous = 0;"))
db))
(define (log-local-event toppath . loglst)
(let ((logline (apply conc loglst)))
(log-event logline)))
(define (log-event toppath logline)
(let ((db (open-logging-db toppath)))
(sql:exec
(sql:sql db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);")
logline
(current-directory)
(string-intersperse (argv) " ")
(current-process-id))
logline))
;;======================================================================
;; paths and directories
;;======================================================================
;; return first path that can be created or already exists and is writable
;;
(define (get-create-writeable-dir dirs)
(if (null? dirs)
#f
(let loop ((hed (car dirs))
(tal (cdr dirs)))
(let ((res (or (and (directory? hed)
(file-write-access? hed)
hed)
(handle-exceptions
exn
(begin
;; (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.")
(print "INFO: could not create " hed ", this might cause problems down the road.")
#f)
(create-directory hed #t)))))
(if (and (string? res)
(directory? res))
res
(if (null? tal)
#f
(loop (car tal)(cdr tal))))))))
(define old-file-exists? file-exists?)
(define (file-exists? path-string)
;; this avoids stack dumps. NOTE: The issues that triggered this approach might have been fixed TODO: test and remove if possible
;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
(handle-exceptions
exn
#f
(old-file-exists? path-string)))
;;======================================================================
;; pkts stuff
;;======================================================================
;; load-pkts-to-db *used* to take a list of pkts dirs and roll them into a single db. This is now broken.
;;
(define (load-pkts-to-db pktsdir setup-pdbpath toppath #!key (use-lt #f)(log-port (current-error-port)))
(let ((pktsdirs (if (list? pktsdir) pktsdir `(,pktsdir)))
(pktsdir (if (list? pktsdir) (car pktsdir) pktsdir)))
(with-queue-db
pktsdir
setup-pdbpath
toppath
(lambda (pktsdirs pktsdir pdb)
(for-each
(lambda (pktsdir) ;; look at all
(cond
((not (file-exists? pktsdir))
(debug-print 0 log-port "ERROR: packets directory " pktsdir " does not exist."))
((not (directory? pktsdir))
(debug-print 0 log-port "ERROR: packets directory path " pktsdir " is not a directory."))
((not (file-read-access? pktsdir))
(debug-print 0 log-port "ERROR: packets directory path " pktsdir " is not readable."))
(else
(print-info 0 log-port "Loading packets found in " pktsdir)
(let ((pkts (glob (conc pktsdir "/*.pkt"))))
(for-each
(lambda (pkt)
(let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))
(exists (lookup-by-uuid pdb uuid #f)))
(if (not exists)
(let* ((pktdat (string-intersperse
(with-input-from-file pkt read-lines)
"\n"))
(apkt (pkt->alist pktdat))
(ptype (alist-ref 'T apkt)))
(add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0)
(debug-print 4 log-port "Added " uuid " of type " ptype " to queue"))
(debug-print 4 log-port "pkt: " uuid " exists, skipping...")
)))
pkts)))))
pktsdirs))
use-lt: use-lt)))
(define (get-pkt-alists pkts)
(map (lambda (x)
(alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt
pkts))
(define (with-queue-db pktsdir setup-pdbpath toppath proc #!key (use-lt #f)(log-port (current-error-port)))
(let* ((pktsdirs (if (list? pktsdir) pktsdir `(,pktsdir))) ;; FIXME, ignoring all possible pkts dirs for now. (get-pkts-dirs use-lt pktsdir-str))
(pktsdir (if (list? pktsdir)(car pktsdir) pktsdir))
;; (toppath toppath-in) ;; (or (configf:lookup mtconf "scratchdat" "toppath") toppath-in))
(pdbpath (or setup-pdbpath pktsdir))) ;; (configf:lookup mtconf "setup" "pdbpath")
(cond
((not pktsdir)
(debug-print 0 log-port "ERROR: pktsdir missing from setup section in your megatest.config for area management."))
((not toppath)
(debug-print 0 log-port "ERROR: toppath not found, area management config problem?"))
((not pdbpath)
(debug-print 0 log-port "ERROR: pdbpath not found. Should be derived from pktsdir?"))
((not (directory-exists? pktsdir))
(debug-print 0 log-port "ERROR: pkts directory not found " pktsdir))
((not (equal? (file-owner pktsdir)(current-effective-user-id)))
(debug-print 0 log-port "ERROR: directory " pktsdir " is not owned by " (current-effective-user-name)))
(else
(let* ((pdb (open-queue-db pdbpath "pkts.db"
schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))))
(proc pktsdirs pktsdir pdb)
(dbi:close pdb))))))
;; look at consolidating this with mtut.scm get-pkts-dir
;;
;; (configf:lookup mtconf "setup" "pktsdirs")
(define (get-pkts-dirs use-lt #!key (top-path #f)(pktsdirs #f))
(let* ((pktsdirs-str (or pktsdirs
(and use-lt
(conc (or top-path
(current-directory))
"/lt/.pkts"))))
(pktsdirs (if pktsdirs-str
(string-split pktsdirs-str " ")
#f)))
pktsdirs))
;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending
;; also delete duplicates by target i.e. (car pkt)
;;
(define (get-pkt-times pkts)
(delete-duplicates
(sort
(map (lambda (x)
`(,(alist-ref 't x) . ,(string->number (alist-ref 'D x))))
pkts)
(lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending
(lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target
;;======================================================================
;; T I M E A N D D A T E
;;======================================================================
;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
(define (hms-string->seconds tstr)
(let ((parts (string-split-fields "\\w+" tstr))
(time-secs 0)
;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks
(trx (regexp "(\\d+)([smhdMyw])")))
(for-each (lambda (part)
(let ((match (string-match trx part)))
(if match
(let ((val (string->number (cadr match)))
(unt (caddr match)))
(if val
(set! time-secs (+ time-secs (* val
(case (string->symbol unt)
((s) 1)
((m) 60) ;; minutes
((h) 3600)
((d) 86400)
((w) 604800)
((M) 2628000) ;; aproximately one month
((y) 31536000)
(else #f))))))))))
parts)
time-secs))
(define (seconds->hr-min-sec secs)
(let* ((hrs (quotient secs 3600))
(min (quotient (- secs (* hrs 3600)) 60))
(sec (- secs (* hrs 3600)(* min 60))))
(conc (if (> hrs 0)(conc hrs "hr ") "")
(if (> min 0)(conc min "m ") "")
sec "s")))
(define (seconds->time-string sec)
(time->string
(seconds->local-time sec) "%H:%M:%S"))
(define (seconds->work-week/day-time sec)
(time->string
(seconds->local-time sec) "ww%V.%u %H:%M"))
(define (seconds->work-week/day sec)
(time->string
(seconds->local-time sec) "ww%V.%u"))
(define (seconds->year-work-week/day sec)
(time->string
(seconds->local-time sec) "%yww%V.%w"))
(define (seconds->year-work-week/day-time sec)
(time->string
(seconds->local-time sec) "%Yww%V.%w %H:%M"))
(define (seconds->year-week/day-time sec)
(time->string
(seconds->local-time sec) "%Yw%V.%w %H:%M"))
(define (seconds->quarter sec)
(case (string->number
(time->string
(seconds->local-time sec)
"%m"))
((1 2 3) 1)
((4 5 6) 2)
((7 8 9) 3)
((10 11 12) 4)
(else #f)))
;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch
;;
(define (date-time->seconds datetime)
(local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S")))
;; given span of seconds tstart to tend
;; find start time to mark and mark delta
;;
(define (find-start-mark-and-mark-delta tstart tend)
(let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ...
(result #f)
(min 60)
(hr (* 60 60))
(day (* 24 hr))
(yr (* 365 day)) ;; year
(mo (/ yr 12))
(wk (* day 7)))
(for-each
(lambda (max-blks)
(for-each
(lambda (span) ;; 5 2 1
(if (not result)
(for-each
(lambda (timeunit timesym) ;; year month day hr min sec
(if (not result)
(let* ((time-blk (* span timeunit))
(num-blks (quotient deltat time-blk)))
(if (and (> num-blks 4)(< num-blks max-blks))
(let ((first (* (quotient tstart time-blk) time-blk)))
(set! result (list span timeunit time-blk first timesym))
)))))
(list yr mo wk day hr min 1)
'( y mo w d h m s))))
(list 8 6 5 2 1)))
'(5 10 15 20 30 40 50 500))
(if values
(apply values result)
(values 0 day 1 0 'd))))
;; given x y lim return the cron expansion
;;
(define (expand-cron-slash x y lim)
(let loop ((curr x)
(res `()))
(if (< curr lim)
(loop (+ curr y) (cons curr res))
(reverse res))))
;; expand a complex cron string to a list of cron strings
;;
;; x/y => x, x+y, x+2y, x+3y while x+Ny<max_for_field
;; a,b,c => a, b ,c
;;
;; NOTE: with flatten a lot of the crud below can be factored down.
;;
(define (cron-expand cron-str)
(if (list? cron-str)
(flatten
(fold (lambda (x res)
(if (list? x)
(let ((newres (map cron-expand x)))
(append x newres))
(cons x res)))
'()
cron-str)) ;; (map common:cron-expand cron-str))
(let ((cron-items (string-split cron-str))
(slash-rx (regexp "(\\d+)/(\\d+)"))
(comma-rx (regexp ".*,.*"))
(max-vals '((min . 60)
(hour . 24)
(dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations
(month . 12)
(dayofweek . 7))))
(if (< (length cron-items) 5) ;; bad spec
cron-str ;; `(,cron-str) ;; just return the string, something downstream will fix it
(let loop ((hed (car cron-items))
(tal (cdr cron-items))
(type 'min)
(type-tal '(hour dayofmonth month dayofweek))
(res '()))
(regex-case
hed
(slash-rx ( _ base incr ) (let* ((basen (string->number base))
(incrn (string->number incr))
(expanded-vals (expand-cron-slash basen incrn (alist-ref type max-vals)))
(new-list-crons (fold (lambda (x myres)
(cons (conc (if (null? res)
""
(conc (string-intersperse res " ") " "))
x " " (string-intersperse tal " "))
myres))
'() expanded-vals)))
;; (print "new-list-crons: " new-list-crons)
;; (fold (lambda (x res)
;; (if (list? x)
;; (let ((newres (map common:cron-expand x)))
;; (append x newres))
;; (cons x res)))
;; '()
(flatten (map cron-expand new-list-crons))))
;; (map common:cron-expand (map common:cron-expand new-list-crons))))
(else (if (null? tal)
cron-str
(loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed)))))))))))
;; given a cron string and the last time event was processed return #t to run or #f to not run
;;
;; min hour dayofmonth month dayofweek
;; 0-59 0-23 1-31 1-12 0-6 ### NOTE: dayofweek does not include 7
;;
;; #t => yes, run the job
;; #f => no, do not run the job
;;
(define (cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW.
(let* ((cron-items (map string->number (string-split cron-str)))
(now-seconds (or now-seconds-in (current-seconds)))
(now-time (seconds->local-time now-seconds))
(last-done-time (seconds->local-time last-done))
(all-times (make-hash-table)))
;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items))
(if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings
#f
(match-let ((( cmin chour cdayofmonth cmonth cdayofweek)
cron-items)
;; 0 1 2 3 4 5 6
((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9)
(vector->list now-time))
((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9)
(vector->list last-done-time)))
;; create all possible time slots
;; remove invalid slots due to (for example) day of week
;; get the start and end entries for the ref-seconds (current) time
;; if last-done > ref-seconds => this is an ERROR!
;; does the last-done time fall in the legit region?
;; yes => #f do not run again this command
;; no => #t ok to run the command
(for-each ;; month
(lambda (month)
(for-each ;; dayofmonth
(lambda (dom)
(for-each
(lambda (hr) ;; hour
(for-each
(lambda (minute) ;; minute
(let ((copy-now (apply vector (vector->list now-time))))
(vector-set! copy-now 0 0) ;; force seconds to zero
(vector-set! copy-now 1 minute)
(vector-set! copy-now 2 hr)
(vector-set! copy-now 3 dom) ;; dom is already corrected for zero referenced
(vector-set! copy-now 4 month)
(let* ((copy-now-secs (local-time->seconds copy-now))
(new-copy (seconds->local-time copy-now-secs))) ;; remake the time vector
(if (or (not cdayofweek)
(equal? (vector-ref new-copy 6)
cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified
(if (or (not cdayofmonth)
(equal? (vector-ref new-copy 3)
(+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified
(hash-table-set! all-times copy-now-secs new-copy))))))
(if cmin
`(,cmin) ;; if given cmin, have to use it
(list (- nmin 1) nmin (+ nmin 1))))) ;; minute
(if chour
`(,chour)
(list (- nhour 1) nhour (+ nhour 1))))) ;; hour
(if cdayofmonth
`(,cdayofmonth)
(list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1)))))
(if cmonth
`(,cmonth)
(list (- nmonth 1) nmonth (+ nmonth 1))))
(let ((before #f)
(is-in #f))
(for-each
(lambda (moment)
(if (and before
(<= before now-seconds)
(>= moment now-seconds))
(begin
;; (print)
;; (print "Before: " (time->string (seconds->local-time before)))
;; (print "Now: " (time->string (seconds->local-time now-seconds)))
;; (print "After: " (time->string (seconds->local-time moment)))
;; (print "Last: " (time->string (seconds->local-time last-done)))
(if (< last-done before)
(set! is-in before))
))
(set! before moment))
(sort (hash-table-keys all-times) <))
is-in)))))
(define (extended-cron cron-str now-seconds-in last-done)
(let ((expanded-cron (cron-expand cron-str)))
(if (string? expanded-cron)
(cron-event expanded-cron now-seconds-in last-done)
(let loop ((hed (car expanded-cron))
(tal (cdr expanded-cron)))
(if (cron-event hed now-seconds-in last-done)
#t
(if (null? tal)
#f
(loop (car tal)(cdr tal))))))))
(define (get-param-mapping #!key (flavor #f))
"returns alist mapping string keys in testconfig/subrun to megatest command line switches; if flavor is switch-symbol, maps tcmt symbolic switches to megatest switches"
(let ((default '(("tag-expr" . "-tagexpr")
("mode-patt" . "-modepatt")
("run-name" . "-runname")
("contour" . "-contour")
("target" . "-target")
("test-patt" . "-testpatt")
("msg" . "-m")
("log" . "-log")
("start-dir" . "-start-dir")
("new" . "-set-state-status"))))
(if (eq? flavor 'switch-symbol)
(map (lambda (x)
(cons (string->symbol (conc "-" (car x))) (cdr x)))
default)
default)))
)