1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
|
(conc run-id "," test-id) #f))
(test-name (db:test-get-testname testdat))
(item-path (db:test-get-item-path testdat))
(state (db:test-get-state testdat))
(status (db:test-get-status testdat))
(event-time (db:test-get-event_time testdat))
(duration (db:test-get-run_duration testdat)))
(if (and (not (member state '("DELETED" "REMOTEHOSTSTART" "RUNNING" "LAUNCHED""NOT_STARTED")))
(not (and prevdat
(equal? state (db:test-get-state prevdat))
(equal? status (db:test-get-status prevdat)))))
(let ((fmt (runs:gendat-inc-results-fmt *runs:general-data*))
(dtime (seconds->year-work-week/day-time event-time)))
(if (runs:lownoise "inc-print" 600)
(format #t fmt "State" "Status" "Start Time" "Duration" "Test path"))
|
|
|
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
|
(conc run-id "," test-id) #f))
(test-name (db:test-get-testname testdat))
(item-path (db:test-get-item-path testdat))
(state (db:test-get-state testdat))
(status (db:test-get-status testdat))
(event-time (db:test-get-event_time testdat))
(duration (db:test-get-run_duration testdat)))
(if (and (not (member state '("DELETED" "REMOTEHOSTSTART" "RUNNING" "LAUNCHED" "LAUNCHING" "NOT_STARTED")))
(not (and prevdat
(equal? state (db:test-get-state prevdat))
(equal? status (db:test-get-status prevdat)))))
(let ((fmt (runs:gendat-inc-results-fmt *runs:general-data*))
(dtime (seconds->year-work-week/day-time event-time)))
(if (runs:lownoise "inc-print" 600)
(format #t fmt "State" "Status" "Start Time" "Duration" "Test path"))
|
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
|
(if (> (current-seconds)(+ last-time-incomplete 900))
(let ((actual-num-running (rmt:get-count-tests-running-for-run-id run-id #f))) ;; fastmode=no
(debug:print-info 0 *default-log-port* "Marking stuck tests as INCOMPLETE while waiting for run " run-id
". Running as pid " (current-process-id) " on " (get-host-name))
(set! last-time-incomplete (current-seconds)) ;; FIXME, this might be causing slow down - use of set!
(rmt:find-and-mark-incomplete run-id #f)
(debug:print-info 0 *default-log-port* "run-wait specified, waiting on " actual-num-running
" tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at "
(time->string (seconds->local-time (current-seconds))))))
;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
(thread-sleep! 5) ;; (if (>= num-running max-concurrent-jobs) 5 1))
(wait-loop (rmt:get-count-tests-running-for-run-id run-id #t) ;; fastmode=yes
num-running))))
;; LET* ((test-record
;; we get here on "drop through". All done!
|
|
|
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
|
(if (> (current-seconds)(+ last-time-incomplete 900))
(let ((actual-num-running (rmt:get-count-tests-running-for-run-id run-id #f))) ;; fastmode=no
(debug:print-info 0 *default-log-port* "Marking stuck tests as INCOMPLETE while waiting for run " run-id
". Running as pid " (current-process-id) " on " (get-host-name))
(set! last-time-incomplete (current-seconds)) ;; FIXME, this might be causing slow down - use of set!
(rmt:find-and-mark-incomplete run-id #f)
(debug:print-info 0 *default-log-port* "run-wait specified, waiting on " actual-num-running
" tests in RUNNING, REMOTEHOSTSTART, LAUNCHING or LAUNCHED state at "
(time->string (seconds->local-time (current-seconds))))))
;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
(thread-sleep! 5) ;; (if (>= num-running max-concurrent-jobs) 5 1))
(wait-loop (rmt:get-count-tests-running-for-run-id run-id #t) ;; fastmode=yes
num-running))))
;; LET* ((test-record
;; we get here on "drop through". All done!
|
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
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
|
(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry runsdat testdat-rec)
;; All these vars might be referenced by the testconfig file reader
;;
;; NEED to reprocess testconfig here, ensuring that item variables are available.
;; This is for Tal's issue with item-specific env vars not being set for use in skip.
;; HSD https://hsdes.intel.com/appstore/icf/index.html#/article?articleId=1408763273
;;
(let* ((test-name (tests:testqueue-get-testname test-record))
(test-waitons (tests:testqueue-get-waitons test-record))
(itemdat (tests:testqueue-get-itemdat test-record))
(item-path "")
(db #f)
(full-test-name #f))
;; setting itemdat to a list if it is #f
(if (not itemdat)(set! itemdat '()))
(set! item-path (item-list->path itemdat))
(set! full-test-name (db:test-make-full-name test-name item-path))
(let* ((test-conf ;; re-instate the tests:get-testconfig once the kinks are worked out. FIXME!!!
;; (tests:get-testconfig test-name item-path all-tests-registry #t force-create: #t))
(tests:testqueue-get-testconfig test-record ))
(test-path (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ...
(hash-table-ref/default flags "-force" #f))
(incomplete-timeout (string->number (or (configf:lookup *configdat* "setup" "incomplete-timeout") "x")))
)
"\nTESTNAME: " full-test-name
"\n test-config: " (hash-table->alist test-conf)
"\n itemdat: " itemdat
)
(debug:print 2 *default-log-port* "Attempting to launch test " full-test-name)
;; (setenv "MT_TEST_NAME" test-name) ;;
;; (setenv "MT_ITEMPATH" item-path)
;; (setenv "MT_RUNNAME" runname)
(change-directory *toppath*)
;; Here is where the test_meta table is best updated
;; Yes, another use of a global for caching. Need a better way?
;;
;; There is now a single call to runs:update-all-test_meta and this
;; per-test call is not needed. Given the delicacy of the move to
;; v1.55 this code is being left in place for the time being.
;;
(if (not (hash-table-ref/default *test-meta-updated* test-name #f))
(begin
(hash-table-set! *test-meta-updated* test-name #t)
(runs:update-test_meta test-name test-conf)))
;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer"))
(let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
(test-id (rmt:get-test-id run-id test-name item-path))
(testdat (if test-id (rmt:get-test-info-by-id run-id test-id) #f)))
(if (not testdat)
(let loop ()
;; ensure that the path exists before registering the test
;; NOPE: Cannot! Don't know yet which disk area will be assigned....
;; (system (conc "mkdir -p " new-test-path))
;;
;; (open-run-close tests:register-test db run-id test-name item-path)
;;
;; NB// for the above line. I want the test to be registered long before this routine gets called!
;;
(if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path)))
(if (not test-id)
(begin
(debug:print 2 *default-log-port* "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id)
(rmt:register-test run-id test-name item-path)
(set! test-id (rmt:get-test-id run-id test-name item-path))))
(debug:print-info 4 *default-log-port* "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"")
(set! testdat (rmt:get-test-info-by-id run-id test-id))
(if (not testdat)
(begin
(debug:print-info 0 *default-log-port* "WARNING: server is overloaded, trying again in two seconds")
;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
(thread-sleep! 2)
(loop)))))
(if (not testdat) ;; should NOT happen
(debug:print-error 0 *default-log-port* "failed to get test record for test-id " test-id))
(set! test-id (db:test-get-id testdat))
(if (common:file-exists? test-path)
(change-directory test-path)
(begin
(debug:print-error 0 *default-log-port* "test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?")
(change-directory *toppath*)))
(case (if force ;; (args:get-arg "-force")
'NOT_STARTED
(if testdat
(string->symbol (test:get-state testdat))
'failed-to-insert))
((failed-to-insert)
(debug:print-error 0 *default-log-port* "Failed to insert the record into the db"))
((NOT_STARTED COMPLETED DELETED INCOMPLETE)
(let ((runflag #f))
(cond
;; -force, run no matter what
(force (set! runflag #t))
;; NOT_STARTED, run no matter what
((member (test:get-state testdat) '("DELETED" "NOT_STARTED" "INCOMPLETE"))(set! runflag #t))
;; not -rerun and PASS, WARN or CHECK, do no run
((and (or (not rerun)
keepgoing)
;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK
(or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP" "WAIVED"))
(member (test:get-state testdat) '("COMPLETED"))))
(debug:print-info 2 *default-log-port* "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat))
(hash-table-set! test-registry full-test-name 'DONOTRUN) ;; COMPLETED)
(set! runflag #f))
;; -rerun and status is one of the specifed, run it
((and rerun
(let* ((rerunlst (string-split rerun ","))
(must-rerun (member (test:get-status testdat) rerunlst)))
(debug:print-info 3 *default-log-port* "-rerun list: " rerun ", test-status: " (test:get-status testdat)", must-rerun: " must-rerun)
must-rerun))
(debug:print-info 2 *default-log-port* "Rerun forced for test " test-name "/" item-path)
(set! runflag #t))
;; -keepgoing, do not rerun FAIL
((and keepgoing
(member (test:get-status testdat) '("FAIL")))
(set! runflag #f))
((and (not rerun)
(member (test:get-status testdat) '("FAIL" "n/a")))
(set! runflag #t))
(else (set! runflag #f)))
(debug:print 4 *default-log-port* "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat))
(if (not runflag)
(if (not parent-test)
(if (runs:lownoise (conc "not starting test" full-test-name) 60)
(debug:print 1 *default-log-port* "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat)
"\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat)
"\" or -force to override")))
;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are
;; already met.
;; This would be a great place to do the process-fork
;;
(let ((skip-test #f)
(skip-check (configf:get-section test-conf "skip")))
(cond
;; Have to check for skip conditions. This one skips if there are same-named tests
;; currently running
((and skip-check
(configf:lookup test-conf "skip" "prevrunning"))
;; run-ids = #f means *all* runs
(let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f)))
(if (not (null? running-tests)) ;; have to skip
(set! skip-test "Skipping due to previous tests running"))))
;; split the string and OR of file-exists?
((and skip-check
(configf:lookup test-conf "skip" "fileexists"))
(let* ((files (string-split (configf:lookup test-conf "skip" "fileexists")))
(existing (filter common:file-exists? files)))
(if (not (null? existing)) ;; (common:file-exists? (configf:lookup test-conf "skip" "fileexists"))
(set! skip-test (conc "Skipping due to existance of file(s) " (string-intersperse existing ", ")))))) ;; (configf:lookup test-conf "skip" "fileexists")))))
((and skip-check
(configf:lookup test-conf "skip" "filenotexists"))
(let* ((files (string-split (configf:lookup test-conf "skip" "filenotexists")))
(existing (filter common:file-exists? files)))
(if (null? existing) ;; (common:file-exists? (configf:lookup test-conf "skip" "filenotexists")))
(set! skip-test (conc "Skipping due to non existance of files " (string-intersperse files ", ")))))) ;; (configf:lookup test-conf "skip" "filenotexists")))))
((and skip-check
(configf:lookup test-conf "skip" "script"))
(if (= (system (configf:lookup test-conf "skip" "script")) 0)
(set! skip-test (conc "Skipping due to zero return value of script " (configf:lookup test-conf "skip" "script")))))
((and skip-check
(configf:lookup test-conf "skip" "rundelay"))
;; run-ids = #f means *all* runs
(let* ((numseconds (common:hms-string->seconds (configf:lookup test-conf "skip" "rundelay")))
(running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))
(completed-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("COMPLETED" "INCOMPLETE") '("PASS" "FAIL" "ABORT") #f)) ;; ironically INCOMPLETE is same as COMPLETED in this contex
(last-run-times (map db:mintest-get-event_time completed-tests))
(time-since-last (- (current-seconds) (if (null? last-run-times) 0 (common:max last-run-times)))))
(if (or (not (null? running-tests)) ;; have to skip if test is running
(> numseconds time-since-last))
(set! skip-test (conc "Skipping due to previous test run less than " (configf:lookup test-conf "skip" "rundelay") " ago"))))))
(if skip-test
(begin
(mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test)
(debug:print-info 1 *default-log-port* "SKIPPING Test " full-test-name " due to " skip-test))
;;
;; Here the test is handed off to launch.scm for launch-test to complete the launch process
;;
(begin
;; wait for less than max jobs here
(if (runs:dat-wait-for-jobs-function runsdat)
((runs:dat-wait-for-jobs-function runsdat) testdat-rec))
(if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags))
(begin
(print "ERROR: Failed to launch the test. Exiting as soon as possible")
(set! *globalexitstatus* 1) ;;
(process-signal (current-process-id) signal/kill))
)
;; wait again here?
))))))
((KILLED)
(debug:print 1 *default-log-port* "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.")
(hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED))
((LAUNCHED REMOTEHOSTSTART RUNNING)
(debug:print 2 *default-log-port* "NOTE: " test-name " is already running"))
;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
;; (db:test-get-run_duration testdat)))
;; (or incomplete-timeout
;; 6000)) ;; i.e. no update for more than 6000 seconds
;; (begin
;; (debug:print 0 *default-log-port* "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
;; ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
;; (debug:print 2 *default-log-port* "NOTE: " test-name " is already running")))
(else
(debug:print-error 0 *default-log-port* "Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat))
(case (string->symbol (test:get-state testdat))
((COMPLETED INCOMPLETE)
(hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN))
(else
(hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)))))))))
;;======================================================================
;; END OF NEW STUFF
;;======================================================================
(define (get-dir-up-n dir . params)
(let ((dparts (string-split dir "/"))
|
|
|
|
|
<
|
>
>
>
<
<
<
|
<
|
|
|
<
|
|
|
|
|
>
|
<
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
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
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
|
(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry runsdat testdat-rec)
;; All these vars might be referenced by the testconfig file reader
;;
;; NEED to reprocess testconfig here, ensuring that item variables are available.
;; This is for Tal's issue with item-specific env vars not being set for use in skip.
;; HSD https://hsdes.intel.com/appstore/icf/index.html#/article?articleId=1408763273
;;
(let* ((test-name (tests:testqueue-get-testname test-record))
(test-waitons (tests:testqueue-get-waitons test-record))
(itemdat (or (tests:testqueue-get-itemdat test-record) '()))
(item-path (item-list->path itemdat))
(full-test-name (db:test-make-full-name test-name item-path))
(test-id (rmt:get-test-id run-id test-name item-path)))
;; NOTE: Getting here does NOT mean that the test will be launched.
;; setting itemdat to a list if it is #f
(runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) ;; these may be needed by the launching process
(let* ((test-conf ;; re-instate the tests:get-testconfig once the kinks are worked out. FIXME!!!
;; (tests:get-testconfig test-name item-path all-tests-registry #t force-create: #t))
(tests:testqueue-get-testconfig test-record ))
(test-path (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ...
(forceopt (hash-table-ref/default flags "-force" #f))
(rerun (hash-table-ref/default flags "-rerun" #f))
(keepgoing (hash-table-ref/default flags "-keepgoing" #f))
(incomplete-timeout (string->number (or (configf:lookup *configdat* "setup" "incomplete-timeout") "x"))))
(debug:print-info 4 *default-log-port*
"\nTESTNAME: " full-test-name
"\n test-config: " (hash-table->alist test-conf)
"\n itemdat: " itemdat
)
(debug:print 2 *default-log-port* "Attempting to launch test " full-test-name)
(change-directory *toppath*)
;; Here is where the test_meta table is best updated
;; Yes, another use of a global for caching. Need a better way?
;;
;; There is now a single call to runs:update-all-test_meta and this
;; per-test call is not needed. Given the delicacy of the move to
;; v1.55 this code is being left in place for the time being.
;;
(if (not (hash-table-ref/default *test-meta-updated* test-name #f))
(begin
(hash-table-set! *test-meta-updated* test-name #t)
(runs:update-test_meta test-name test-conf)))
;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer"))
(let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
(test-id (or test-id (rmt:get-test-id run-id test-name item-path)))
(testdat (if test-id (rmt:get-test-info-by-id run-id test-id) #f)))
(if (not testdat)
(let loop ()
(if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path)))
(if (not test-id)
(begin
(debug:print 0 *default-log-port* "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id)
(rmt:register-test run-id test-name item-path)
(set! test-id (rmt:get-test-id run-id test-name item-path))))
(debug:print-info 4 *default-log-port* "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"")
(set! testdat (rmt:get-test-info-by-id run-id test-id))
(if (not testdat)
(begin
(debug:print-info 0 *default-log-port* "WARNING: server is overloaded, trying again in two seconds")
;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
(thread-sleep! 2)
(loop)))))
(if (not testdat) ;; should NOT happen
(debug:print-error 0 *default-log-port* "failed to get test record for test-id " test-id))
(set! test-id (db:test-get-id testdat))
(if (common:file-exists? test-path)
(change-directory test-path)
(begin
(debug:print-error 0 *default-log-port* "test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?")
(change-directory *toppath*)))
(case (if forceopt ;; (args:get-arg "-force")
'NOT_STARTED
(if testdat
(string->symbol (test:get-state testdat))
'failed-to-insert))
((failed-to-insert)
(debug:print-error 0 *default-log-port* "Failed to insert the record into the db"))
((NOT_STARTED COMPLETED DELETED INCOMPLETE)
(let ((runflag #f))
(cond
;; -force, run no matter what
(force (set! runflag #t))
;; NOT_STARTED, run no matter what
((member (test:get-state testdat) '("DELETED" "NOT_STARTED" "INCOMPLETE"))(set! runflag #t))
;; not -rerun and PASS, WARN or CHECK, do no run
((and (or (not rerun)
keepgoing)
;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK
(or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP" "WAIVED"))
(member (test:get-state testdat) '("COMPLETED"))))
(debug:print-info 2 *default-log-port* "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat))
(hash-table-set! test-registry full-test-name 'DONOTRUN) ;; COMPLETED)
(set! runflag #f))
;; -rerun and status is one of the specifed, run it
((and rerun
(let* ((rerunlst (string-split rerun ","))
(must-rerun (member (test:get-status testdat) rerunlst)))
(debug:print-info 3 *default-log-port* "-rerun list: " rerun ", test-status: " (test:get-status testdat)", must-rerun: " must-rerun)
must-rerun))
(debug:print-info 2 *default-log-port* "Rerun forced for test " test-name "/" item-path)
(set! runflag #t))
;; -keepgoing, do not rerun FAIL
((and keepgoing
(member (test:get-status testdat) '("FAIL")))
(set! runflag #f))
((and (not rerun)
(member (test:get-status testdat) '("FAIL" "n/a")))
(set! runflag #t))
(else (set! runflag #f)))
(debug:print 4 *default-log-port* "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat))
(if (not runflag)
(if (not parent-test)
(if (runs:lownoise (conc "not starting test" full-test-name) 60)
(debug:print 1 *default-log-port* "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat)
"\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat)
"\" or -force to override")))
;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are
;; already met.
;; This would be a great place to do the process-fork
;;
(let ((skip-test #f)
(skip-check (configf:get-section test-conf "skip")))
(cond
;; Have to check for skip conditions. This one skips if there are same-named tests
;; currently running
((and skip-check
(configf:lookup test-conf "skip" "prevrunning"))
;; run-ids = #f means *all* runs
(let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHING" "LAUNCHED") '() #f)))
(if (not (null? running-tests)) ;; have to skip
(set! skip-test "Skipping due to previous tests running"))))
;; split the string and OR of file-exists?
((and skip-check
(configf:lookup test-conf "skip" "fileexists"))
(let* ((files (string-split (configf:lookup test-conf "skip" "fileexists")))
(existing (filter common:file-exists? files)))
(if (not (null? existing)) ;; (common:file-exists? (configf:lookup test-conf "skip" "fileexists"))
(set! skip-test (conc "Skipping due to existance of file(s) " (string-intersperse existing ", ")))))) ;; (configf:lookup test-conf "skip" "fileexists")))))
((and skip-check
(configf:lookup test-conf "skip" "filenotexists"))
(let* ((files (string-split (configf:lookup test-conf "skip" "filenotexists")))
(existing (filter common:file-exists? files)))
(if (null? existing) ;; (common:file-exists? (configf:lookup test-conf "skip" "filenotexists")))
(set! skip-test (conc "Skipping due to non existance of files " (string-intersperse files ", ")))))) ;; (configf:lookup test-conf "skip" "filenotexists")))))
((and skip-check
(configf:lookup test-conf "skip" "script"))
(if (= (system (configf:lookup test-conf "skip" "script")) 0)
(set! skip-test (conc "Skipping due to zero return value of script " (configf:lookup test-conf "skip" "script")))))
((and skip-check
(configf:lookup test-conf "skip" "rundelay"))
;; run-ids = #f means *all* runs
(let* ((numseconds (common:hms-string->seconds (configf:lookup test-conf "skip" "rundelay")))
(running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHING" "LAUNCHED") '() #f))
(completed-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("COMPLETED" "INCOMPLETE") '("PASS" "FAIL" "ABORT") #f)) ;; ironically INCOMPLETE is same as COMPLETED in this contex
(last-run-times (map db:mintest-get-event_time completed-tests))
(time-since-last (- (current-seconds) (if (null? last-run-times) 0 (common:max last-run-times)))))
(if (or (not (null? running-tests)) ;; have to skip if test is running
(> numseconds time-since-last))
(set! skip-test (conc "Skipping due to previous test run less than " (configf:lookup test-conf "skip" "rundelay") " ago"))))))
(if skip-test
(begin
(mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test)
(debug:print-info 1 *default-log-port* "SKIPPING Test " full-test-name " due to " skip-test))
;;
;; Here the test is handed off to launch.scm for launch-test to complete the launch process
;;
(begin
;; first thing to do is to set the test to LAUNCHING to prevent or minimise
;; races on exclusive mode and max_concurrent_jobs
(if (equal? (test:get-state testdat) "NOT_STARTED")
(rmt:test-set-state-status run-id test-id "LAUNCHING" "n/a" #f)
(debug:print 0 *default-log-port* "Odd, test " test-id " is in state " (test:get-state testdat) " yet we are trying to launch it."))
;; wait for less than max jobs here
(if (runs:dat-wait-for-jobs-function runsdat)
((runs:dat-wait-for-jobs-function runsdat) testdat-rec))
(if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags))
(begin
(print "ERROR: Failed to launch the test. Exiting as soon as possible")
(set! *globalexitstatus* 1) ;;
(process-signal (current-process-id) signal/kill))
)
;; wait again here?
))))))
((KILLED)
(debug:print 1 *default-log-port* "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.")
(hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED))
((LAUNCHING LAUNCHED REMOTEHOSTSTART RUNNING)
(debug:print 2 *default-log-port* "NOTE: " test-name " is already running"))
;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
;; (db:test-get-run_duration testdat)))
;; (or incomplete-timeout
;; 6000)) ;; i.e. no update for more than 6000 seconds
;; (begin
;; (debug:print 0 *default-log-port* "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
;; ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
;; (debug:print 2 *default-log-port* "NOTE: " test-name " is already running")))
(else
(debug:print-error 0 *default-log-port* "Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat))
(case (string->symbol (test:get-state testdat))
((COMPLETED INCOMPLETE)
(hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN))
(else
(hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)))))))))
;;======================================================================
;; END OF NEW STUFF
;;======================================================================
(define (get-dir-up-n dir . params)
(let ((dparts (string-split dir "/"))
|
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
|
) ; end case rem-status
) ; end let
); end cond has-subrun
(else
;; BB - TODO - consider backgrounding to threads to delete tests (work below)
(debug:print-info 0 *default-log-port* "test: " test-name " itest-state: " test-state)
(if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))
(begin
(if (not (hash-table-ref/default test-retry-time test-fulln #f))
(begin
;; want to set to REMOVING BUT CANNOT do it here?
(hash-table-set! test-retry-time test-fulln (current-seconds))))
(if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time)
;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first
|
|
|
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
|
) ; end case rem-status
) ; end let
); end cond has-subrun
(else
;; BB - TODO - consider backgrounding to threads to delete tests (work below)
(debug:print-info 0 *default-log-port* "test: " test-name " itest-state: " test-state)
(if (member test-state (list "RUNNING" "LAUNCHING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))
(begin
(if (not (hash-table-ref/default test-retry-time test-fulln #f))
(begin
;; want to set to REMOVING BUT CANNOT do it here?
(hash-table-set! test-retry-time test-fulln (current-seconds))))
(if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time)
;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first
|
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
|
(if (not (null? tal))
(loop (car tal)(cdr tal)))))))
(rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
((kill-runs)
;; RUNNING -> KILLREQ
;; LAUNCHED,RUNNING,REMOTEHOSTSTART -> NOT STARTED
(cond
((and has-subrun (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")))
(common:send-thunk-to-background-thread
(lambda ()
(let* ((subrun-remove-succeeded
(subrun:kill-subrun run-dir keep-records)))
#t)))
(if (not (null? tal))
(loop (car tal)(cdr tal)))
|
|
|
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
|
(if (not (null? tal))
(loop (car tal)(cdr tal)))))))
(rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
((kill-runs)
;; RUNNING -> KILLREQ
;; LAUNCHED,RUNNING,REMOTEHOSTSTART -> NOT STARTED
(cond
((and has-subrun (member test-state (list "RUNNING" "LAUNCHING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")))
(common:send-thunk-to-background-thread
(lambda ()
(let* ((subrun-remove-succeeded
(subrun:kill-subrun run-dir keep-records)))
#t)))
(if (not (null? tal))
(loop (car tal)(cdr tal)))
|
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
|
(test-state (vector-ref test 3))
(comment (vector-ref test 14))
(test-status (vector-ref test 4))
(exc-msg (conc "No bucket for State " test-state " Status " test-status))
(new-doc (cond
((member test-state (list "RUNNING" ))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc))
((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc))
((member test-status (list "PASS" "WARN" "WAIVED"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc))
((member test-status (list "FAIL" "CHECK"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc))
((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc))
|
|
|
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
|
(test-state (vector-ref test 3))
(comment (vector-ref test 14))
(test-status (vector-ref test 4))
(exc-msg (conc "No bucket for State " test-state " Status " test-status))
(new-doc (cond
((member test-state (list "RUNNING" ))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc))
((member test-state (list "LAUNCHING" "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc))
((member test-status (list "PASS" "WARN" "WAIVED"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc))
((member test-status (list "FAIL" "CHECK"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc))
((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc))
|