;;======================================================================
;; 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/>.
;;======================================================================
;;======================================================================
;; Megatestmod:
;;
;; Put things here don't fit anywhere else
;;======================================================================
(declare (unit mtmod))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses commonmod))
(declare (uses configfmod))
;; (declare (uses tcp-transportmod)) ;; we don't want mtmod depending on tcp
(use srfi-69)
(module mtmod
(
keys:make-key/field-string
common:get-testsuite-name
items:get-items-from-config
mt:run-trigger
common:get-linktree
common:get-area-name
items:check-valid-items
mt:discard-blocked-tests
)
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
(prefix base64 base64:)
(prefix sqlite3 sqlite3:)
data-structures
directory-utils
extras
files
matchable
md5
message-digest
pathname-expand
posix
posix-extras
regex
regex-case
sparse-vectors
srfi-1
srfi-18
srfi-69
typed-records
z3
debugprint
commonmod
configfmod
;; tcp-transportmod
(prefix mtargs args:)
)
(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
)))
;; imports common to chk5 and ck4
(import srfi-13)
;; (include "db_records.scm")
;;======================================================================
;; stuff from keys that can't be in commonmod. Maybe move all from commonmod to here?
;;======================================================================
(define (keys:make-key/field-string confdat)
(let ((fields (configf:get-section confdat "fields")))
(string-join
(map (lambda (field)(conc (car field) " " (cadr field)))
fields)
",")))
;;======================================================================
;; testsuite and area utilites
;;======================================================================
(define (common:get-linktree)
(or (getenv "MT_LINKTREE")
(if *configdat*
(configf:lookup *configdat* "setup" "linktree")
#f)
(if (or *toppath* (getenv "MT_RUN_AREA_HOME"))
(conc (or *toppath* (getenv "MT_RUN_AREA_HOME")) "/lt")
#f)
(let* ((tp (common:get-toppath #f))
(lt (conc tp "/lt")))
(if (not tp)(debug:print 0 *default-log-port* "WARNING: cannot calculate best path for linktree, using " lt))
lt)))
(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 (common:get-testsuite-name)
(or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
(configf:lookup *configdat* "setup" "testsuite" )
(getenv "MT_TESTSUITE_NAME")
(pathname-file (or (if (string? *toppath* )
(pathname-file *toppath*)
#f)
(common:get-toppath #f)))
"please-set-setup-area-name")) ;; (pathname-file (current-directory)))))
;; 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
(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)))
;; 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)))
;;======================================================================
;; redefine for future cleanup (converge on area-name, the more generic
;;
(define common:get-area-name common:get-testsuite-name)
(define (common:get-db-tmp-area . junk)
(if *db-cache-path*
*db-cache-path*
(if *toppath* ;; common:get-create-writeable-dir
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path* ", exn=" exn)
(exit 1))
(let* ((toppath (common:real-path *toppath*))
(tsname (common:get-testsuite-name))
(dbpath (common:get-create-writeable-dir
(list (conc "/tmp/" (current-user-name)
"/megatest_localdb/"
tsname "/"
(string-translate toppath "/" "."))
(conc "/tmp/" (current-process-id) ;; just in case we have an issue with the dir by own user name
"/"(current-user-name) "/megatest_localdb/"
tsname
(string-translate toppath "/" "."))
))))
(set! *db-cache-path* dbpath)
;; ensure megatest area has .mtdb
(let ((dbarea (conc *toppath* "/.mtdb")))
(if (not (file-exists? dbarea))
(create-directory dbarea)))
;; ensure tmp area has .mtdb
(let ((dbarea (conc dbpath "/.mtdb")))
(if (not (file-exists? dbarea))
(create-directory dbarea)))
dbpath))
#f)))
;======================================================================
;; T R I G G E R S
;;======================================================================
(define (mt:run-trigger cmd test-id test-rundir trigger logname test-name item-path event-time actual-state actual-status target runname)
;; Putting the commandline into ( )'s means no control over the shell.
;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files
;; or equivalent. No need to do this. Just run it?
(let* ((new-trigger-format (configf:lookup *configdat* "setup" "new-trigger-format"))
(fullcmd
(if (and new-trigger-format (string=? new-trigger-format "yes"))
(conc "nbfake "
cmd " "
test-id " "
test-rundir " "
trigger " "
actual-state " "
actual-status " "
event-time " "
target " "
runname " "
test-name " "
item-path
)
(conc "nbfake "
cmd " "
test-id " "
test-rundir " "
trigger " "
test-name " "
item-path " "
actual-state " "
actual-status " "
event-time
)
))
(prev-nbfake-log (get-environment-variable "NBFAKE_LOG")))
(setenv "NBFAKE_LOG" (conc (cond
((and (directory-exists? test-rundir)
(file-write-access? test-rundir))
test-rundir)
((and (directory-exists? *toppath*)
(file-write-access? *toppath*))
*toppath*)
(else (conc "/tmp/" (current-user-name))))
"/" logname))
(debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG"))
(process-run fullcmd)
(if prev-nbfake-log
(setenv "NBFAKE_LOG" prev-nbfake-log)
(unsetenv "NBFAKE_LOG"))
))
(define (mt:discard-blocked-tests run-id failed-test tests test-records)
(if (null? tests)
tests
(begin
(debug:print-info 1 *default-log-port* "Discarding tests from " tests " that are waiting on " failed-test)
(let loop ((testn (car tests))
(remt (cdr tests))
(res '()))
(let* ((test-dat (hash-table-ref/default test-records testn (vector #f #f '())))
(waitons (vector-ref test-dat 2)))
;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons)
(if (null? remt)
(let ((new-res (reverse res)))
;; (print " new-res: " new-res)
new-res)
(loop (car remt)
(cdr remt)
(if (member failed-test waitons)
(begin
(debug:print 0 *default-log-port* "Discarding test " testn "(" test-dat ") due to " failed-test)
res)
(cons testn res)))))))))
;; Puts out all combinations
(define (process-itemlist hierdepth curritemkey itemlist)
(let ((res '()))
(if (not hierdepth)
(set! hierdepth (length itemlist)))
(let loop ((hed (car itemlist))
(tal (cdr itemlist)))
(if (null? tal)
(for-each (lambda (item)
(if (> (length curritemkey) (- hierdepth 2))
(set! res (append res (list (append curritemkey (list (list (car hed) item))))))))
(cadr hed))
(begin
(for-each (lambda (item)
(set! res (append res (process-itemlist hierdepth (append curritemkey (list (list (car hed) item))) tal))))
(cadr hed))
(loop (car tal)(cdr tal)))))
res))
;; (item-assoc->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Fall")))
;; => ((("ANIMAL" "Elephant") ("SEASON" "Spring"))
;; (("ANIMAL" "Elephant") ("SEASON" "Fall"))
;; (("ANIMAL" "Lion") ("SEASON" "Spring"))
;; (("ANIMAL" "Lion") ("SEASON" "Fall")))
(define (item-assoc->item-list itemsdat)
(if (and itemsdat (not (null? itemsdat)))
(let ((itemlst (filter (lambda (x)
(list? x))
(map (lambda (x)
(debug:print 6 *default-log-port* "item-assoc->item-list x: " x)
(if (< (length x) 2)
(begin
(debug:print-error 0 *default-log-port* "malformed items spec " (string-intersperse x " "))
(list (car x)'()))
(let* ((name (car x))
(items (cadr x))
(ilist (list name (if (string? items)
(string-split items)
'()))))
(if (null? ilist)
(debug:print-error 0 *default-log-port* "No items specified for " name))
ilist)))
itemsdat))))
(let ((debuglevel 5))
(debug:print 5 *default-log-port* "item-assoc->item-list: itemsdat => itemlst ")
(if (debug:debug-mode 5)
(begin
(pp itemsdat)
(print " => ")
(pp itemlst))))
(if (> (length itemlst) 0)
(process-itemlist #f '() itemlst)
'()))
'())) ;; return a list consisting on a single null list for non-item runs
;; Nope, not now, return null as of 6/6/2011
;; (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter")))
;; => ((("ANIMAL" "Elephant")("SEASON" "Spring"))
;; (("ANIMAL" "Lion") ("SEASON" "Winter")))
(define (item-table->item-list itemtable)
(let ((newlst (map (lambda (x)
(if (> (length x) 1)
(list (car x)
(string-split (cadr x)))
(list x '())))
itemtable))
(res '())) ;; a list of items
(let loop ((indx 0)
(item '()) ;; an item will be ((KEYNAME1 VAL1)(KEYNAME2 VAL2) ...)
(elflag #f))
(for-each (lambda (row)
(let ((rowname (car row))
(rowdat (cadr row)))
(set! item (append item
(list
(if (< indx (length rowdat))
(let ((new (list rowname (list-ref rowdat indx))))
;; (debug:print 0 *default-log-port* "New: " new)
(set! elflag #t)
new
) ;; i.e. had at least on legit value to use
(list rowname "-")))))))
newlst)
(if elflag
(begin
(set! res (append res (list item)))
(loop (+ indx 1)
'()
#f)))
res)))
;; Nope, not now, return null as of 6/6/2011
(define (items:check-valid-items class item)
(let ((valid-values (let ((s (configf:lookup *configdat* "validvalues" class)))
(if s (string-split s) #f))))
(if valid-values
(if (member item valid-values)
item #f)
item)))
;; '(("k1" "k2" "k3")
;; ("a" "b" "c")
;; ("d" "e" "f"))
;;
;; => '((("k1" "a")("k2" "b")("k3" "c"))
;; (("k1" "d")("k2" "e")("k3" "f")))
;;
(define (items:first-row-intersperse data)
(if (< (length data) 2)
'()
(let ((header (car data))
(rows (cdr data)))
(map (lambda (row)
(map list header row))
rows))))
;; k1/k2/k3
;; a/b/c
;; d/e/f
;; => '(("k1" "k2" "k3")
;; ("a" "b" "c")
;; ("d" "e" "f"))
;;
;; => '((("k1" "a")("k2" "b")("k3" "c"))
;; (("k1" "d")("k2" "e")("k3" "f")))
;;
(define (items:read-items-file fname ftype) ;; 'sxml 'slash 'space
(if (and fname (file-exists? fname))
(items:first-row-intersperse (case ftype
((slash space)
(let ((splitter (case ftype
((slash) (lambda (x)(string-split x "/")))
(else string-split))))
(debug:print 0 *default-log-port* "Reading " fname " of type " ftype)
(with-input-from-file fname
(lambda ()
(let loop ((inl (read-line))
(res '()))
(if (eof-object? inl)
res
(loop (read-line)(cons (splitter inl) res))))))))
((sxml)(with-input-from-file fname read))
(else (debug:print 0 *default-log-port* "items file type " ftype " not recognised"))))
(begin
(if fname (debug:print 0 *default-log-port* "no items file " fname " found"))
'())))
(define (items:get-items-from-config tconfig)
(let* ((slashf (configf:lookup tconfig "itemopts" "slash")) ;; a/b/c\nd/e/f\n ...
(sxmlf (configf:lookup tconfig "itemopts" "sxml")) ;; '(("a" "b" "c")("d" "e" "f") ...)
(spacef (configf:lookup tconfig "itemopts" "space")) ;; a b c\nd e f\n ...
(have-items (hash-table-ref/default tconfig "items" #f))
(have-itable (hash-table-ref/default tconfig "itemstable" #f))
(items (hash-table-ref/default tconfig "items" '()))
(itemstable (hash-table-ref/default tconfig "itemstable" '())))
(debug:print 5 *default-log-port* "items: " items " itemstable: " itemstable)
(set! items (map (lambda (item)
(if (procedure? (cadr item))
(list (car item)((cadr item))) ;; evaluate the proc
item))
items))
(set! itemstable (map (lambda (item)
(if (procedure? (cadr item))
(list (car item)((cadr item))) ;; evaluate the proc
item))
itemstable))
(if (and have-items (null? items)) (debug:print 0 *default-log-port* "WARNING:[items] section in testconfig but no entries defined"))
(if (and have-itable (null? itemstable))(debug:print 0 *default-log-port* "WARNNG:[itemstable] section in testconfig but no entries defined"))
(if (or (not (null? items))
(not (null? itemstable))
slashf
sxmlf
spacef)
(append (item-assoc->item-list items)
(item-table->item-list itemstable)
(items:read-items-file slashf 'slash)
(items:read-items-file sxmlf 'sxml)
(items:read-items-file spacef 'space))
'(()))))
;; (pp (item-assoc->item-list itemdat))
)