4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
|
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(tests . ,(sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time))
(test_steps . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time))
(test_data . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>=?" since-time))
;; (test_meta . ,(fold-row backcons '() db "SELECT id FROM test_meta WHERE last_update>?" since-time))
(run_stats . ,(sqlite3:fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time))
)))))
;;======================================================================
;; tdb stuff
;;======================================================================
;;======================================================================
;; Database access
;;======================================================================
;; (require-extension (srfi 18) extras tcp)
;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
;; (import (prefix sqlite3 sqlite3:))
;; (import (prefix base64 base64:))
;;
;; (declare (unit tdb))
;; (declare (uses common))
;; (declare (uses keys))
;; (declare (uses ods))
;; (declare (uses client))
;; (declare (uses mt))
;; (declare (uses db))
;;
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
;; (include "run_records.scm")
;;======================================================================
;;
;; T E S T D A T A B A S E S
;;
;;======================================================================
;;======================================================================
;; T E S T S P E C I F I C D B
;;======================================================================
;; Create the sqlite db for the individual test(s)
;;
;; Moved these tables into <runid>.db
;; THIS CODE TO BE REMOVED
;;
;; (define (open-test-db work-area)
;; (debug:print-info 11 *default-log-port* "open-test-db " work-area)
;; (if (and work-area
;; (directory? work-area)
;; (file-readable? work-area))
;; (let* ((dbpath (conc work-area "/testdat.db"))
;; (dbexists (common:file-exists? dbpath))
;; (work-area-writeable (file-writable? work-area))
;; (db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem
;; exn
;; (begin
;; (print-call-chain (current-error-port))
;; (debug:print 2 *default-log-port* "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
;; ((condition-property-accessor 'exn 'message) exn))
;; (set! dbexists #f) ;; must force re-creation of tables, more tom-foolery
;; (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access
;; (if (or work-area-writeable
;; dbexists)
;; (sqlite3:open-database dbpath)
;; (sqlite3:open-database ":memory:"))))
;; (tdb-writeable (and (file-writable? work-area)
;; (file-writable? dbpath)))
;; (handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout")
;; (string->number (args:get-arg "-override-timeout"))
;; 136000))))
;;
;; (if (and tdb-writeable
;; *db-write-access*)
;; (sqlite3:set-busy-handler! db handler))
;; (if (not dbexists)
;; (begin
;; (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;")
;; (debug:print-info 11 *default-log-port* "Initialized test database " dbpath)
;; (tdb:testdb-initialize db)))
;; ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
;; (debug:print-info 11 *default-log-port* "open-test-db END (sucessful)" work-area)
;; ;; now let's test that everything is correct
;; (handle-exceptions
;; exn
;; (begin
;; (print-call-chain (current-error-port))
;; (debug:print-error 0 *default-log-port* "problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file "
;; dbpath ".\n "
;; ((condition-property-accessor 'exn 'message) exn))
;; #f)
;; ;; Is there a cheaper single line operation that will check for existance of a table
;; ;; and raise an exception ?
;; (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;"))
;; db)
;; ;; no work-area or not readable - create a placeholder to fake rest of world out
;; (let ((baddb (sqlite3:open-database ":memory:")))
;; (debug:print-info 11 *default-log-port* "open-test-db END (unsucessful)" work-area)
;; ;; provide an in-mem db (this is dangerous!)
;; (tdb:testdb-initialize baddb)
;; baddb)))
;; ;; find and open the testdat.db file for an existing test
;; (define (tdb:open-test-db-by-test-id test-id #!key (work-area #f))
;; (let* ((test-path (if work-area
;; work-area
;; (rmt:test-get-rundir-from-test-id test-id))))
;; (debug:print 3 *default-log-port* "TEST PATH: " test-path)
;; (open-test-db test-path)))
;;
;; ;; find and open the testdat.db file for an existing test
;; (define (tdb:open-test-db-by-test-id-local dbstruct run-id test-id #!key (work-area #f))
;; (let* ((test-path (if work-area
;; work-area
;; (db:test-get-rundir-from-test-id dbstruct run-id test-id))))
;; (debug:print 3 *default-log-port* "TEST PATH: " test-path)
;; (open-test-db test-path)))
;;
;; ;; find and open the testdat.db file for an existing test
;; (define (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id work-area proc . params)
;; (let* ((test-path (if work-area
;; work-area
;; (db:test-get-rundir-from-test-id dbstruct run-id test-id)))
;; (tdb (open-test-db test-path)))
;; (apply proc tdb params)))
;; (define (tdb:testdb-initialize db)
;; (debug:print 11 *default-log-port* "db:testdb-initialize START")
;; (sqlite3:with-transaction
;; db
;; (lambda ()
;; (for-each
;; (lambda (sqlcmd)
;; (sqlite3:execute db sqlcmd))
;; (list "CREATE TABLE IF NOT EXISTS test_rundat (
;; id INTEGER PRIMARY KEY,
;; update_time TIMESTAMP,
;; cpuload INTEGER DEFAULT -1,
;; diskfree INTEGER DEFAULT -1,
;; diskusage INTGER DEFAULT -1,
;; run_duration INTEGER DEFAULT 0);"
;; "CREATE TABLE IF NOT EXISTS test_data (
;; id INTEGER PRIMARY KEY,
;; test_id INTEGER,
;; category TEXT DEFAULT '',
;; variable TEXT,
;; value REAL,
;; expected REAL,
;; tol REAL,
;; units TEXT,
;; comment TEXT DEFAULT '',
;; status TEXT DEFAULT 'n/a',
;; type TEXT DEFAULT '',
;; CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));"
;; "CREATE TABLE IF NOT EXISTS test_steps (
;; id INTEGER PRIMARY KEY,
;; test_id INTEGER,
;; stepname TEXT,
;; state TEXT DEFAULT 'NOT_STARTED',
;; status TEXT DEFAULT 'n/a',
;; event_time TIMESTAMP,
;; comment TEXT DEFAULT '',
;; logfile TEXT DEFAULT '',
;; CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));"
;; ;; test_meta can be used for handing commands to the test
;; ;; e.g. KILLREQ
;; ;; the ackstate is set to 1 once the command has been completed
;; "CREATE TABLE IF NOT EXISTS test_meta (
;; id INTEGER PRIMARY KEY,
;; var TEXT,
;; val TEXT,
;; ackstate INTEGER DEFAULT 0,
;; CONSTRAINT metadat_constraint UNIQUE (var));"))))
;; (debug:print 11 *default-log-port* "db:testdb-initialize END"))
;; This routine moved to db:read-test-data
;;
(define (tdb:read-test-data tdb test-id categorypatt)
(let ((res '()))
(sqlite3:for-each-row
(lambda (id test_id category variable value expected tol units comment status type)
(set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
tdb
"SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
(sqlite3:finalize! tdb)
(reverse res)))
;;======================================================================
;; T E S T D A T A
;;======================================================================
;; ;; get a list of test_data records matching categorypatt
;; (define (tdb:read-test-data test-id categorypatt #!key (work-area #f))
;; (let ((tdb (tdb:open-test-db-by-test-id test-id work-area: work-area)))
;; (if (sqlite3:database? tdb)
;; (let ((res '()))
;; (sqlite3:for-each-row
;; (lambda (id test_id category variable value expected tol units comment status type)
;; (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
;; tdb
;; "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
;; (sqlite3:finalize! tdb)
;; (reverse res))
;; '())))
(define (tdb:get-prev-tol-for-test tdb test-id category variable)
;; Finish me?
(values #f #f #f))
;;======================================================================
;; S T E P S
;;======================================================================
(define (tdb:step-get-time-as-string vec)
(seconds->time-string (tdb:step-get-event_time vec)))
;; get a pretty table to summarize steps
;;
;; NOT USED, WILL BE REMOVED
;;
(define (tdb:get-steps-table steps);; organise the steps for better readability
(let ((res (make-hash-table)))
(for-each
(lambda (step)
(debug:print 6 *default-log-port* "step=" step)
(let ((record (hash-table-ref/default
res
(tdb:step-get-stepname step)
;; stepname start end status Duration Logfile
(vector (tdb:step-get-stepname step) "" "" "" "" ""))))
(debug:print 6 *default-log-port* "record(before) = " record
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))
(case (string->symbol (tdb:step-get-state step))
((start)(vector-set! record 1 (tdb:step-get-event_time step))
(vector-set! record 3 (if (equal? (vector-ref record 3) "")
(tdb:step-get-status step)))
(if (> (string-length (tdb:step-get-logfile step))
0)
(vector-set! record 5 (tdb:step-get-logfile step))))
((end)
(vector-set! record 2 (any->number (tdb:step-get-event_time step)))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
(endt (any->number (vector-ref record 2))))
(debug:print 4 *default-log-port* "record[1]=" (vector-ref record 1)
", startt=" startt ", endt=" endt
", get-status: " (tdb:step-get-status step))
(if (and (number? startt)(number? endt))
(seconds->hr-min-sec (- endt startt)) "-1")))
(if (> (string-length (tdb:step-get-logfile step))
0)
(vector-set! record 5 (tdb:step-get-logfile step))))
(else
(vector-set! record 2 (tdb:step-get-state step))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (tdb:step-get-event_time step))))
(hash-table-set! res (tdb:step-get-stepname step) record)
(debug:print 6 *default-log-port* "record(after) = " record
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))))
;; (else (vector-set! record 1 (tdb:step-get-event_time step)))
(sort steps (lambda (a b)
(cond
((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)
((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b))
(< (tdb:step-get-id a) (tdb:step-get-id b)))
(else #f)))))
res))
;; Move this to steps.scm
;;
;; get a pretty table to summarize steps
;;
(define (tdb:get-steps-table-list steps)
;; organise the steps for better readability
(let ((res (make-hash-table)))
(for-each
(lambda (step)
(debug:print 6 *default-log-port* "step=" step)
(let ((record (hash-table-ref/default
res
(tdb:step-get-stepname step)
;; stepname start end status
(vector (tdb:step-get-stepname step) "" "" "" "" ""))))
(debug:print 6 *default-log-port* "record(before) = " record
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))
(case (string->symbol (tdb:step-get-state step))
((start)(vector-set! record 1 (tdb:step-get-event_time step))
(vector-set! record 3 (if (equal? (vector-ref record 3) "")
(tdb:step-get-status step)))
(if (> (string-length (tdb:step-get-logfile step))
0)
(vector-set! record 5 (tdb:step-get-logfile step))))
((end)
(vector-set! record 2 (any->number (tdb:step-get-event_time step)))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
(endt (any->number (vector-ref record 2))))
(debug:print 4 *default-log-port* "record[1]=" (vector-ref record 1)
", startt=" startt ", endt=" endt
", get-status: " (tdb:step-get-status step))
(if (and (number? startt)(number? endt))
(seconds->hr-min-sec (- endt startt)) "-1")))
(if (> (string-length (tdb:step-get-logfile step))
0)
(vector-set! record 5 (tdb:step-get-logfile step))))
(else
(vector-set! record 2 (tdb:step-get-state step))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (tdb:step-get-event_time step))))
(hash-table-set! res (tdb:step-get-stepname step) record)
(debug:print 6 *default-log-port* "record(after) = " record
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))))
;; (else (vector-set! record 1 (tdb:step-get-event_time step)))
(sort steps (lambda (a b)
(cond
((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)
((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b))
(< (tdb:step-get-id a) (tdb:step-get-id b)))
(else #f)))))
res))
;;
;; Move to steps.scm
;;
(define (tdb:get-compressed-steps comprsteps) ;; from tdb:get-steps-table
(map (lambda (x)
;; take advantage of the \n on time->string
(vector
(vector-ref x 0)
(let ((s (vector-ref x 1)))
(if (number? s)(seconds->time-string s) s))
(let ((s (vector-ref x 2)))
(if (number? s)(seconds->time-string s) s))
(vector-ref x 3) ;; status
(vector-ref x 4)
(vector-ref x 5))) ;; time delta
(sort (hash-table-values comprsteps)
(lambda (a b)
(let ((time-a (vector-ref a 1))
(time-b (vector-ref b 1)))
(if (and (number? time-a)(number? time-b))
(if (< time-a time-b)
#t
(if (eq? time-a time-b)
(string<? (conc (vector-ref a 2))
(conc (vector-ref b 2)))
#f))
(string<? (conc time-a)(conc time-b))))))))
;;
;; (define (tdb:remote-update-testdat-meta-info run-id test-id work-area cpuload diskfree minutes)
;; (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area)))
;; (if (sqlite3:database? tdb)
;; (begin
;; (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);"
;; cpuload diskfree minutes)
;; (sqlite3:finalize! tdb))
;; (debug:print 2 *default-log-port* "Can't update testdat.db for test " test-id " read-only or non-existant"))))
;;
;;
;;======================================================================
;; 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)
;; 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* ((fullcmd (conc "nbfake "
cmd " "
test-id " "
test-rundir " "
trigger " "
test-name " "
item-path " " ;; has / prepended to deal with toplevel tests
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-writable? test-rundir))
test-rundir)
((and (directory-exists? *toppath*)
(file-writable? *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"))
;; (call-with-environment-variables
;; `(("NBFAKE_LOG" . ,(conc test-rundir "/" logname)))
;; (lambda ()
(process-run fullcmd)
(if prev-nbfake-log
(setenv "NBFAKE_LOG" prev-nbfake-log)
(unsetenv "NBFAKE_LOG"))
)) ;; ))
(define (mt:process-triggers dbstruct run-id test-id newstate newstatus)
(if test-id
(let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id)))
(if test-dat
(let* ((test-rundir (db:test-get-rundir test-dat)) ;; ) ;; )
(test-name (db:test-get-testname test-dat))
(item-path (db:test-get-item-path test-dat))
(duration (db:test-get-run_duration test-dat))
(comment (db:test-get-comment test-dat))
(event-time (db:test-get-event_time test-dat))
(tconfig #f)
(state (if newstate newstate (db:test-get-state test-dat)))
(status (if newstatus newstatus (db:test-get-status test-dat))))
;; (mutex-lock! *triggers-mutex*)
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* " Exception in mt:process-triggers for run-id="run-id" test-id="test-id" newstate="newstate" newstatus="newstatus
"\n error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn
"\n test-rundir="test-rundir
"\n test-name="test-name
"\n item-path="item-path
"\n state="state
"\n status="status
"\n")
(print-call-chain (current-error-port))
#f)
(if (and test-name
test-rundir) ;; #f means no dir set yet
;; (common:file-exists? test-rundir)
;; (directory? test-rundir))
(call-with-environment-variables
(list (cons "MT_TEST_NAME" (or test-name "no such test"))
(cons "MT_TEST_RUN_DIR" (or test-rundir "no test directory yet"))
(cons "MT_ITEMPATH" (or item-path "")))
(lambda ()
(if (directory-exists? test-rundir)
(push-directory test-rundir)
(push-directory *toppath*))
(set! tconfig (mt:lazy-read-test-config test-name))
(for-each (lambda (trigger)
(let* ((munged-trigger (string-translate trigger "/ " "--"))
(logname (conc "last-trigger-" munged-trigger ".log")))
;; first any triggers from the testconfig
(let ((cmd (configf:lookup tconfig "triggers" trigger)))
(if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "tconfig-" logname) test-name item-path event-time state status)))
;; next any triggers from megatest.config
(let ((cmd (configf:lookup *configdat* "triggers" trigger)))
(if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "mtconfig-" logname) test-name item-path event-time state status)))))
(list
(conc state "/" status)
(conc state "/")
(conc "/" status)))
(pop-directory))
)))
;; (mutex-unlock! *triggers-mutex*)
)))))
(define (mt:lazy-read-test-config test-name)
(let ((tconf (hash-table-ref/default *testconfigs* test-name #f)))
(if tconf
tconf
(let ((test-dirs (tests:get-tests-search-path *configdat*)))
(let loop ((hed (car test-dirs))
(tal (cdr test-dirs)))
;; Setting MT_LINKTREE here is almost certainly unnecessary.
(let ((tconfig-file (conc hed "/" test-name "/testconfig")))
(if (and (common:file-exists? tconfig-file)
(file-readable? tconfig-file))
(let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
(old-link-tree (get-environment-variable "MT_LINKTREE")))
(if link-tree-path (setenv "MT_LINKTREE" link-tree-path))
(let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]
(hash-table-set! *testconfigs* test-name newtcfg)
(if old-link-tree
(setenv "MT_LINKTREE" old-link-tree)
(unsetenv "MT_LINKTREE"))
newtcfg))
(if (null? tal)
(begin
(debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name)
#f)
(loop (car tal)(cdr tal))))))))))
)
|