;;======================================================================
;; Copyright 2017, 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/>.
;;======================================================================
(declare (unit commonmod))
(declare (uses debugprint))
(use srfi-69)
(module commonmod
*
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
(prefix sqlite3 sqlite3:)
data-structures
extras
files
matchable
md5
message-digest
pathname-expand
posix
posix-extras
regex
regex-case
srfi-1
srfi-18
srfi-69
typed-records
debugprint
)
(use srfi-69))
(chicken-5
(import (prefix sqlite3 sqlite3:)
;; data-structures
;; extras
;; files
;; posix
;; posix-extras
chicken.base
chicken.condition
chicken.file
chicken.file.posix
chicken.io
chicken.pathname
chicken.port
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.sort
chicken.string
chicken.time
chicken.time.posix
matchable
md5
message-digest
pathname-expand
regex
regex-case
srfi-1
srfi-18
srfi-69
typed-records
system-information
debugprint
)))
;;======================================================================
;; CONTENTS
;;
;; config file utils
;; misc conversion, data manipulation functions
;; testsuite and area utilites
;;
;;======================================================================
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;; http - use the old http + in /tmp db
;; tcp - use tcp transport with cachedb db
;; nfs - use direct to disk access (read-only)
;;
(define rmt:transport-mode (make-parameter 'tcp))
(define (get-full-version)
(conc megatest-version "-" megatest-fossil-hash))
(define (version-signature)
(conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
(define *common:denoise* (make-hash-table)) ;; for low noise printing
(define (common:low-noise-print waitval . keys)
(let* ((key (string-intersperse (map conc keys) "-" ))
(lasttime (hash-table-ref/default *common:denoise* key 0))
(currtime (current-seconds)))
(if (> (- currtime lasttime) waitval)
(begin
(hash-table-set! *common:denoise* key currtime)
#t)
#f)))
;; environment vars handy stuff from common.scm
;;
(define getenv get-environment-variable)
(define (safe-setenv key val)
(if (or (substring-index "!" key)
(substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables.
(substring-index "." key)) ;; periods are not allowed in environment variables
(debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
(if (and (string? val)
(string? key))
(handle-exceptions
exn
(debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val ", exn=" exn)
(setenv key val))
(debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))
;;======================================================================
;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset)
;; execute thunk in context of environment modified as per this list
;; restore env to prior state then return value of eval'd thunk.
;; ** this is not thread safe **
(define (common:with-env-vars delta-env-alist-or-hash-table thunk)
(let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table)
(hash-table->alist delta-env-alist-or-hash-table)
delta-env-alist-or-hash-table))
(restore-thunks
(filter
identity
(map (lambda (env-pair)
(let* ((env-var (car env-pair))
(new-val (let ((tmp (cdr env-pair)))
(if (list? tmp) (car tmp) tmp)))
(current-val (get-environment-variable env-var))
(restore-thunk
(cond
((not current-val) (lambda () (unsetenv env-var)))
((not (string? new-val)) #f)
((eq? current-val new-val) #f)
(else
(lambda () (setenv env-var current-val))))))
;;(when (not (string? new-val))
;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist)
;; (pp delta-env-alist)
;; (exit 1))
(cond
((not new-val) ;; modify env here
(unsetenv env-var))
((string? new-val)
(setenv env-var new-val)))
restore-thunk))
delta-env-alist))))
(let ((rv (thunk)))
(for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state
rv)))
(define home (getenv "HOME"))
(define user (getenv "USER"))
;;======================================================================
;; return a nice clean pathname made absolute
(define (common:nice-path dir)
(let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
(if match ;; using ~ for home?
(common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match)))
(normalize-pathname (if (absolute-pathname? dir)
dir
(conc (current-directory) "/" dir))))))
(define (common:read-link-f path)
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed. exn=" exn)
path) ;; just give up
(with-input-from-pipe
(conc "/bin/readlink -f " path)
(lambda ()
(read-line)))))
;; for reasons I don't understand multiple calls to real-path in parallel threads
;; must be protected by mutexes
;;
(define (common:real-path inpath)
;; (process :cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params)
;; (let-values
;; (((inp oup pid) (process "readlink" (list "-f" inpath))))
;; (with-input-from-port inp
;; (let loop ((inl (read-line))
;; (res #f))
;; (print "inl=" inl)
;; (if (eof-object? inl)
;; (begin
;; (close-input-port inp)
;; (close-output-port oup)
;; ;; (process-wait pid)
;; res)
;; (loop (read-line) inl))))))
(with-input-from-pipe (conc "readlink -f " inpath) read-line))
;; KEEP THIS ONE
;;
;; client:get-signature
(define *my-client-signature* #f)
(define (client:get-signature)
(if *my-client-signature* *my-client-signature*
(let ((sig (conc (get-host-name) " " (current-process-id))))
(set! *my-client-signature* sig)
*my-client-signature*)))
(define *server-info* #f)
(define *toppath* #f)
(define (common:false-on-exception thunk #!key (message #f))
(handle-exceptions exn
(begin
(if message
(debug:print-info 0 *default-log-port* message))
#f) (thunk) ))
(define (common:file-exists? path-string #!key (silent #f))
;;;; TODO: catch permission denied exceptions and emit appropriate warnings. Might be able to get rid of with chicken 5?
(common:false-on-exception (lambda () (file-exists? path-string))
message: (if (not silent)
(conc "Unable to access path: " path-string)
#f)
))
(define (common:directory-exists? path-string)
;;;; TODO: catch permission denied exceptions and emit appropriate warnings
(common:false-on-exception (lambda () (directory-exists? path-string))
message: (conc "Unable to access path: " path-string)
))
;;======================================================================
;; does the directory exist and do we have write access?
;;
;; returns the directory or #f
;;
(define (common:directory-writable? path-string)
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "Failed to identify access to " path-string ", exn=" exn)
#f)
(if (and (directory-exists? path-string)
(file-write-access? path-string))
path-string
#f)))
;;======================================================================
;; config file utils
;;======================================================================
(define (lookup cfgdat section var)
(if (hash-table? cfgdat)
(let ((sectdat (hash-table-ref/default cfgdat section '())))
(if (null? sectdat)
#f
(let ((match (assoc var sectdat)))
(if match ;; (and match (list? match)(> (length match) 1))
(cadr match)
#f))
))
#f))
;; returns var key1=val1; key2=val2 ... as alist
(define (get-key-list cfgdat section var)
;; convert string a=1; b=2; c=a silly thing; d=
(let ((valstr (lookup cfgdat section var)))
(if valstr
(val->alist valstr)
'()))) ;; should it return empty list or #f to indicate not set?
(define (get-section cfgdat section)
(hash-table-ref/default cfgdat section '()))
(define (common:make-tmpdir-name areapath tmpadj)
(let* ((area (pathname-file areapath))
(dname (conc "/tmp/"(current-user-name)"/megatest_localdb/" area "/" (string-translate areapath "/" ".") tmpadj "/.mtdb")))
(unless (directory-exists? dname)
(create-directory dname #t))
dname))
;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again
;; to get the lock
;;
(define (common:simple-file-lock fname #!key (expire-time 300))
(let* ((lock-exists (file-exists? fname))
(fmod-time (if lock-exists
(current-seconds)
(handle-exceptions
ext
(current-seconds)
(file-modification-time fname)))))
(if lock-exists
(if (> (- (current-seconds) fmod-time) expire-time)
(begin
(debug:print-info 1 *default-log-port* "Removing stale lock "fname)
(handle-exceptions exn #f (delete-file* fname))
(common:simple-file-lock fname expire-time: expire-time))
#f)
(let ((key-string (conc (get-host-name) "-" (current-process-id))))
(with-output-to-file fname
(lambda ()
(print key-string)))
(thread-sleep! 0.25)
(if (file-exists? fname) ;; (common:file-exists? fname)
(handle-exceptions exn
#f
(with-input-from-file fname
(lambda ()
(equal? key-string (read-line)))))
#f)))))
(define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
(let ((end-time (+ expire-time (current-seconds))))
(let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
(if got-lock
#t
(if (> end-time (current-seconds))
(begin
(thread-sleep! 3)
(loop (common:simple-file-lock fname expire-time: expire-time)))
#f)))))
(define (common:simple-file-release-lock fname)
(handle-exceptions
exn
#f ;; I don't really care why this failed (at least for now)
(delete-file* fname)))
;;======================================================================
;; misc conversion, data manipulation functions
;;======================================================================
;;======================================================================
;; return first command that exists, else #f
;;
(define (common:which cmds)
(if (null? cmds)
#f
(let loop ((hed (car cmds))
(tal (cdr cmds)))
(let ((res (with-input-from-pipe (conc "which " hed) read-line)))
(if (and (string? res)
(file-exists? res))
res
(if (null? tal)
#f
(loop (car tal)(cdr tal))))))))
(define (common:get-megatest-exe)
(let* ((mtexe (or (get-environment-variable "MT_MEGATEST")
(common:which '("megatest"))
"megatest")))
(if (file-exists? mtexe)
(realpath mtexe)
mtexe)))
(define (common:get-megatest-exe-dir)
(let* ((mtexe (common:get-megatest-exe)))
(pathname-directory mtexe)))
;; more generic and comprehensive version of get-megatest-exe
;;
(define (common:get-mtexe)
(let* ((mtpathdir (common:get-megatest-exe-dir)))
(or (common:get-megatest-exe)
(if mtpathdir
(conc mtpathdir"/megatest")
#f)
"megatest")))
(define (common:get-megatest-exe-path)
(let* ((mtpathdir (common:get-megatest-exe-dir)))
(conc mtpathdir":"(get-environment-variable "PATH") ":.")))
(cond-expand
(chicken-4
(define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) )))
(chicken-5
(define (realpath x) (normalize-pathname (pathname-expand (or x "/dev/null"))))))
;; if it looks like a number -> convert it to a number, else return it
;;
(define (lazy-convert inval)
(let* ((as-num (if (string? inval)(string->number inval) #f)))
(or as-num inval)))
;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
;;
(define (val->alist val #!key (convert #f))
(let ((val-list (string-split-fields ";\\s*" val #:infix)))
(if val-list
(map (lambda (x)
(let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
(case (length f)
((0) `(,#f)) ;; null string case
((1) `(,(string->symbol (car f))))
((2) `(,(string->symbol (car f)) .
,(let ((inval (cadr f)))
(if convert (lazy-convert inval) inval))))
(else f))))
(filter (lambda (x)
(not (string-match "^\\s*" x)))
val-list))
'())))
(define (commonmod:get-cpu-load)
(let* ((load-info (with-input-from-file "/proc/loadavg" read-lines))
(res (map string->number (string-split (car load-info)))))
(if (null? res)
#f ;; something is wrong
(car res))))
(define *current-host-cores* #f)
(define (get-current-host-cores)
(or *current-host-cores*
(let ((cpu-info (with-input-from-file "/proc/cpuinfo" read-lines)))
(let loop ((lines cpu-info))
(if (null? lines)
1 ;; gotta be at least one!
(let* ((inl (car lines))
(tail (cdr lines))
(parts (string-split inl)))
(match parts
(("cpu" "cores" ":" num) (string->number num))
(else (loop tail)))))))))
(define (number-of-processes-running processname)
(with-input-from-pipe
(conc "ps -def | egrep \""processname"\" |wc -l")
(lambda ()
(string->number (read-line)))))
;; get the normalized (i.e. load / numcpus) for *this* host
;;
(define (get-normalized-cpu-load)
(/ (commonmod:get-cpu-load)(get-current-host-cores)))
;;======================================================================
;; testsuite and area utilites
;;======================================================================
(define (get-testsuite-name toppath configdat)
(or (lookup configdat "setup" "area-name")
(lookup configdat "setup" "testsuite")
(get-environment-variable "MT_TESTSUITE_NAME")
(if (string? toppath)
(pathname-file toppath)
#f)))
(define (get-area-path-signature toppath #!optional (short #f))
(let ((res (message-digest-string (md5-primitive) toppath)))
(if short
(substring res 0 4)
res)))
(define (get-area-name configdat toppath #!optional (short #f))
;; look up my area name in areas table (future)
;; generate auto name
(conc (get-area-path-signature toppath short)
"-"
(get-testsuite-name toppath configdat)))
;; need generic find-record-with-var-nmatching-val
;;
(define (path->area-record cfgdat path)
(let* ((areadat (get-cfg-areas cfgdat))
(all (filter (lambda (x)
(let* ((keyvals (cdr x))
(pth (alist-ref 'path keyvals)))
(equal? path pth)))
areadat)))
(if (null? all)
#f
(car all)))) ;; return first match
;; given a config return an alist of alists
;; area-name => data
;;
(define (get-cfg-areas cfgdat)
(let ((adat (get-section cfgdat "areas")))
(map (lambda (entry)
`(,(car entry) .
,(val->alist (cadr entry))))
adat)))
;;======================================================================
;; time utils
;;======================================================================
(define (common:human-time)
(time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S"))
;;======================================================================
;; T I M E A N D D A T E
;;======================================================================
;;======================================================================
;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
(define (common: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
0)))))
(debug:print 0 *default-log-port* "ERROR: can't parse timestring "tstr", component "part", string: "(cadr match))))
(debug:print 0 *default-log-port* "ERROR: can't parse timestring "tstr", component "part))))
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 (common: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 (common: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 (common: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 (common:cron-expand cron-str)
(if (list? cron-str)
(flatten
(fold (lambda (x res)
(if (list? x)
(let ((newres (map common: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 (common: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 common: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 (common: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 (common:extended-cron cron-str now-seconds-in last-done)
(let ((expanded-cron (common:cron-expand cron-str)))
(if (string? expanded-cron)
(common:cron-event expanded-cron now-seconds-in last-done)
(let loop ((hed (car expanded-cron))
(tal (cdr expanded-cron)))
(if (common:cron-event hed now-seconds-in last-done)
#t
(if (null? tal)
#f
(loop (car tal)(cdr tal))))))))
;;======================================================================
;; misc stuff
;;======================================================================
(define (common:get-signature str)
(message-digest-string (md5-primitive) str))
;;======================================================================
;; hash of hashs
;;======================================================================
(define (db:hoh-set! dat key1 key2 val)
(let* ((subhash (hash-table-ref/default dat key1 #f)))
(if subhash
(hash-table-set! subhash key2 val)
(begin
(hash-table-set! dat key1 (make-hash-table))
(db:hoh-set! dat key1 key2 val)))))
(define (db:hoh-get dat key1 key2)
(let* ((subhash (hash-table-ref/default dat key1 #f)))
(and subhash
(hash-table-ref/default subhash key2 #f))))
;;======================================================================
;; when called from a wrapper I need sometimes to find the calling
;; wrapper, this is for dashboard to find the correct megatest.
;;
(define (common:find-local-megatest #!optional (progname "megatest"))
(let ((res (filter file-exists?
(map (lambda (updir)
(let* ((lm (car (argv)))
(dir (pathname-directory lm))
(exe (pathname-strip-directory lm)))
(conc (if dir (conc dir "/") "")
(case (string->symbol exe)
((dboard) (conc updir progname))
((mtest) (conc updir progname))
((dashboard) progname)
(else exe)))))
'("../../" "../")))))
(if (null? res)
(begin
;; (debug:print 0 *default-log-port* "Failed to find this executable! Using what can be found on the path")
progname)
(car res))))
(define (common:generic-ssh ssh-command proc default #!optional (msg-proc #f))
(let ((inp #f))
(handle-exceptions
exn
(begin
(close-input-port inp)
(if msg-proc
(msg-proc)
(debug:print 0 *default-log-port* "Command: \""ssh-command"\" failed. exn="exn))
default)
(set! inp (open-input-pipe ssh-command))
(with-input-from-port inp
(lambda ()
(let ((res (proc)))
(close-input-port inp)
res))))))
;; this is a close duplicate of:
;; process:alist-on-host?
;; process:alive
;;
(define (commonmod:is-test-alive host pid)
(let* ((same-host (equal? host (get-host-name)))
(cmd (conc
(if same-host "" (conc "ssh "host" "))
"pstree -A "pid)))
(if (and host pid
(not (equal? host "n/a")))
(let* ((output (if same-host
(with-input-from-pipe cmd read-lines)
(common:generic-ssh cmd read-lines '())))) ;; (with-input-from-pipe cmd read-lines)))
(debug:print 2 *default-log-port* "Running " cmd " received " output)
(if (eq? (length output) 0)
#f
#t))
#t))) ;; assuming bad query is about a live test is likely not the right thing to do?
)