1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
|
(lambda (count)
(set! res count))
tdb
"SELECT count(id) FROM test_rundat;")
res))
0)
(define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)
(rmt:general-call 'update-test-rundat run-id test-id (current-seconds) (or cpuload -1)(or diskfree -1) -1 (or minutes -1))
(if (and cpuload diskfree)
(rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id))
(if minutes
(rmt:general-call 'update-run-duration run-id minutes test-id))
(if (and uname hostname)
(rmt:general-call 'update-uname-host run-id uname hostname test-id)))
(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)
(let* ((cpuload (get-cpu-load))
(diskfree (get-df (current-directory)))
(remtries 10))
(handle-exceptions
exn
(if (> remtries 0)
(begin
(print-call-chain (current-error-port))
(debug:print-info 0 *default-log-port* "WARNING: failed to set meta info. Will try " remtries " more times")
(set! remtries (- remtries 1))
(thread-sleep! 10)
(tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1)))
(let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
(debug:print-error 0 *default-log-port* "tried for over a minute to update meta info and failed. Giving up")
(debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.")
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 5 *default-log-port* "exn=" (condition->list exn))
(debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
(print-call-chain (current-error-port))))
(tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
)))
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
|
|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
|
(lambda (count)
(set! res count))
tdb
"SELECT count(id) FROM test_rundat;")
res))
0)
;;
(define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname #!key (update-db #f))
(if (get-environment-variable "MT_TEST_RUN_DIR")
(let* ((dest-dir (conc (get-environment-variable "MT_TEST_RUN_DIR") "/.mt_data"))
(or-dash (lambda (instr)(if instr instr "-"))))
(if (not (directory-exists? dest-dir))(create-directory dest-dir #t))
(let* ((outp (open-output-file (conc dest-dir "/test-run.dat") #:append)))
(with-output-to-port outp
(lambda ()
(print (current-seconds) " " (or-dash run-id) " " (or-dash test-id) " "
(or-dash cpuload) " " (or-dash diskfree) " "
(or-dash minutes) " " (or-dash hostname) " "
(or-dash uname)))) ;; put uname last as it has spaces in it
(close-output-port outp)))
(begin
(rmt:general-call 'update-test-rundat run-id test-id (current-seconds) (or cpuload -1)(or diskfree -1) -1 (or minutes -1))))
(if update-db
(begin
(if (and cpuload diskfree)
(rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id))
(if minutes
(rmt:general-call 'update-run-duration run-id minutes test-id))
(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 #!key (update-db #f))
;; (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 update-db: update-db)))
;;======================================================================
;; A R C H I V I N G
;;======================================================================
(define (test:archive db test-id)
#f)
|