| ︙ | | | ︙ | |
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
|
(declare (unit tests))
(declare (uses db))
(declare (uses tdb))
(declare (uses debugprint))
(declare (uses common))
(declare (uses commonmod))
(declare (uses items))
(declare (uses runconfig))
(declare (uses server))
(declare (uses mtargs))
(declare (uses rmtmod))
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking directory-utils)
(import (prefix sqlite3 sqlite3:))
(import commonmod (prefix mtargs args:) debugprint rmtmod)
(require-library stml)
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
|
>
>
|
>
>
>
>
|
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
|
(declare (unit tests))
(declare (uses db))
(declare (uses tdb))
(declare (uses debugprint))
(declare (uses common))
(declare (uses commonmod))
(declare (uses configf))
(declare (uses configfmod))
(declare (uses items))
(declare (uses runconfig))
(declare (uses server))
(declare (uses mtargs))
(declare (uses rmtmod))
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking directory-utils)
(import (prefix sqlite3 sqlite3:))
(import commonmod
configfmod
(prefix mtargs args:)
debugprint
rmtmod)
(require-library stml)
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
|
| ︙ | | | ︙ | |
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
|
(define (tests:save-final-status run-id test-id)
(let* ((test-dat (rmt:get-test-info-by-id run-id test-id))
(out-dir (db:test-get-rundir test-dat))
(status-file (conc out-dir "/.final-status"))
)
;; first verify we are able to write the output file
(if (not (file-write-access? out-dir))
(debug:print 0 *default-log-port* "ERROR: cannot write .final-status to " out-dir)
(let*
((outp (open-output-file status-file))
(status (db:test-get-status test-dat))
(state (db:test-get-state test-dat)))
(fprintf outp "~S\n" state)
(fprintf outp "~S\n" status)
(close-output-port outp)))))
|
|
<
|
|
|
>
>
|
|
<
|
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
|
(define (tests:save-final-status run-id test-id)
(let* ((test-dat (rmt:get-test-info-by-id run-id test-id))
(out-dir (db:test-get-rundir test-dat))
(status-file (conc out-dir "/.final-status"))
)
;; first verify we are able to write the output file
(if (not (file-write-access? out-dir))
(debug:print 0 *default-log-port* "ERROR: cannot write .final-status to " out-dir)
(let* ((outp (open-output-file status-file))
(status (db:test-get-status test-dat))
(state (db:test-get-state test-dat)))
(with-output-to-port outp
(lambda ()
(print state) ;; printf was putting in ", not sure why but that was a hassle in other contexts
(print status)))
(close-output-port outp)))))
;; summarize test in to a file test-summary.html in the test directory
;;
(define (tests:summarize-test run-id test-id)
(let* ((test-dat (rmt:get-test-info-by-id run-id test-id))
(out-dir (db:test-get-rundir test-dat))
(out-file (conc out-dir "/test-summary.html")))
|
| ︙ | | | ︙ | |
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
|
;;======================================================================
;; test steps
;;======================================================================
;; teststep-set-status! used to be here
(define (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)
(let* ((testdat (rmt:get-test-state-status-by-id run-id test-id)))
(and testdat
(equal? (car testdat) "KILLREQ"))))
(define (test:tdb-get-rundat-count tdb)
(if tdb
(let ((res 0))
|
>
|
|
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
|
;;======================================================================
;; test steps
;;======================================================================
;; teststep-set-status! used to be here
;; NOT NEEDED
#;(define (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)
(let* ((testdat (rmt:get-test-state-status-by-id run-id test-id)))
(and testdat
(equal? (car testdat) "KILLREQ"))))
(define (test:tdb-get-rundat-count tdb)
(if tdb
(let ((res 0))
|
| ︙ | | | ︙ | |
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
|
(if (and uname hostname)
(rmt:general-call 'update-uname-host run-id uname hostname test-id)))
;; This one is for running with no db access (i.e. via rmt: internally)
(define (tests:set-full-meta-info db test-id run-id minutes work-area remtries)
;; (define (tests:set-full-meta-info test-id run-id minutes work-area)
;; (let ((remtries 10))
(let* ((cpuload (get-cpu-load))
(diskfree (get-df (current-directory)))
(uname (get-uname "-srvpio"))
(hostname (get-host-name)))
(tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)))
;; (define (tests:set-partial-meta-info test-id run-id minutes work-area)
#;(define (tests:set-partial-meta-info test-id run-id minutes work-area remtries)
|
|
|
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
|
(if (and uname hostname)
(rmt:general-call 'update-uname-host run-id uname hostname test-id)))
;; This one is for running with no db access (i.e. via rmt: internally)
(define (tests:set-full-meta-info db test-id run-id minutes work-area remtries)
;; (define (tests:set-full-meta-info test-id run-id minutes work-area)
;; (let ((remtries 10))
(let* ((cpuload (commonmod:get-cpu-load))
(diskfree (get-df (current-directory)))
(uname (get-uname "-srvpio"))
(hostname (get-host-name)))
(tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)))
;; (define (tests:set-partial-meta-info test-id run-id minutes work-area)
#;(define (tests:set-partial-meta-info test-id run-id minutes work-area remtries)
|
| ︙ | | | ︙ | |