;;======================================================================
;; 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))
(use srfi-69)
(module commonmod
*
(import scheme chicken data-structures extras files)
(import (prefix sqlite3 sqlite3:)
posix typed-records srfi-18 srfi-69
md5 message-digest
regex srfi-1)
;;======================================================================
;; CONTENTS
;;
;; config file utils
;; misc conversion, data manipulation functions
;; testsuite and area utilites
;;
;;======================================================================
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(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)))
;;======================================================================
;; 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 '()))
;; 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 ((fmod-time (handle-exceptions
ext
(current-seconds)
(file-modification-time fname))))
(if (file-exists? fname) ;; (common:file-exists? fname)
(if (> (- (current-seconds) fmod-time) expire-time)
(begin
(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
;;======================================================================
;; 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))
'())))
;;======================================================================
;; 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)))
;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;;
;; (define (set-functions dbgp dbgpinfo)
;; (set! debug:print dbgp)
;; (set! debug:print-info dbgpinfo))
)