Megatest

Diff
Login

Differences From Artifact [86baf587d1]:

To Artifact [f5768c0da1]:


45
46
47
48
49
50
51
52

53
54
55
56
57
58
59
45
46
47
48
49
50
51

52
53
54
55
56
57
58
59







-
+







(define (tests:get-tests-search-path cfgdat)
  (let ((paths (map cadr (configf:get-section cfgdat "tests-paths"))))
    (filter (lambda (d)
	      (if (directory-exists? d)
		  d
		  (begin
		    (if (common:low-noise-print 60 "tests:get-tests-search-path" d)
			(debug:print 0 #f "WARNING: problem with directory " d ", dropping it from tests path"))
			(debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path"))
		    #f)))
	    (append paths (list (conc *toppath* "/tests"))))))

(define (tests:get-valid-tests test-registry tests-paths)
  (if (null? tests-paths) 
      test-registry
      (let loop ((hed (car tests-paths))
99
100
101
102
103
104
105
106

107
108
109
110
111
112
113
99
100
101
102
103
104
105

106
107
108
109
110
111
112
113







-
+







(define (tests:lookup-itemmap itemmaps testname)
  (let ((best-matches (filter (lambda (itemmap)
				(tests:match (car itemmap) testname #f))
			      itemmaps)))
    (if (null? best-matches)
	#f
	(let ((res (car best-matches)))
	  ;; (debug:print 0 #f "res=" res)
	  ;; (debug:print 0 *default-log-port* "res=" res)
	  (cond
	   ((string? res) res) ;;; FIX THE ROOT CAUSE HERE ....
	   ((null? res)   #f)
	   ((string? (cdr res)) (cdr res))  ;; it is a pair
	   ((string? (cadr res))(cadr res)) ;; it is a list
	   (else cadr res))))))

143
144
145
146
147
148
149
150

151
152
153
154
155
156
157
158
159
160
161
162
163
164

165
166
167
168
169
170
171
172
173
174

175
176
177
178
179
180
181
182

183
184
185
186
187
188
189

190
191
192
193
194
195
196
143
144
145
146
147
148
149

150
151
152
153
154
155
156
157
158
159
160
161
162
163

164
165
166
167
168
169
170
171
172
173

174
175
176
177
178
179
180
181

182
183
184
185
186
187
188

189
190
191
192
193
194
195
196







-
+













-
+









-
+







-
+






-
+







;; returns waitons waitors tconfigdat
;;
(define (tests:get-waitons test-name all-tests-registry)
   (let* ((config  (tests:get-testconfig test-name all-tests-registry 'return-procs)))
     (let ((instr (if config 
		      (config-lookup config "requirements" "waiton")
		      (begin ;; No config means this is a non-existant test
			(debug:print 0 #f "ERROR: non-existent required test \"" test-name "\"")
			(debug:print 0 *default-log-port* "ERROR: non-existent required test \"" test-name "\"")
			(exit 1))))
	   (instr2 (if config
		       (config-lookup config "requirements" "waitor")
		       "")))
       (debug:print-info 8 #f "waitons string is " instr ", waitors string is " instr2)
       (let ((newwaitons
	      (string-split (cond
			     ((procedure? instr) ;; here 
			      (let ((res (instr)))
				(debug:print-info 8 #f "waiton procedure results in string " res " for test " test-name)
				res))
			     ((string? instr)     instr)
			     (else 
			      ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 #f "ERROR: something went wrong in processing waitons for test " test-name)
			      ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 *default-log-port* "ERROR: something went wrong in processing waitons for test " test-name)
			      ""))))
	     (newwaitors
	      (string-split (cond
			     ((procedure? instr2)
			      (let ((res (instr2)))
				(debug:print-info 8 #f "waitor procedure results in string " res " for test " test-name)
				res))
			     ((string? instr2)     instr2)
			     (else 
			      ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 #f "ERROR: something went wrong in processing waitons for test " test-name)
			      ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 *default-log-port* "ERROR: something went wrong in processing waitons for test " test-name)
			      "")))))
	 (values
	  ;; the waitons
	  (filter (lambda (x)
		    (if (hash-table-ref/default all-tests-registry x #f)
			#t
			(begin
			  (debug:print 0 #f "ERROR: test " test-name " has unrecognised waiton testname " x)
			  (debug:print 0 *default-log-port* "ERROR: test " test-name " has unrecognised waiton testname " x)
			  #f)))
		  newwaitons)
	  (filter (lambda (x)
		    (if (hash-table-ref/default all-tests-registry x #f)
			#t
			(begin
			  (debug:print 0 #f "ERROR: test " test-name " has unrecognised waiton testname " x)
			  (debug:print 0 *default-log-port* "ERROR: test " test-name " has unrecognised waiton testname " x)
			  #f)))
		  newwaitors)
	  config)))))
					     
;; given waiting-test that is waiting on waiton-test extend test-patt appropriately
;;
;;  genlib/testconfig               sim/testconfig
300
301
302
303
304
305
306
307

308
309
310
311
312
313
314
315

316
317
318
319
320
321
322
323
324
325

326
327
328
329
330
331
332
333
334
335
336
337

338
339
340
341
342
343
344
345
346
347

348
349
350
351
352
353
354
300
301
302
303
304
305
306

307
308
309
310
311
312
313
314

315
316
317
318
319
320
321
322
323
324

325
326
327
328
329
330
331
332
333
334
335
336

337
338
339
340
341
342
343
344
345
346

347
348
349
350
351
352
353
354







-
+







-
+









-
+











-
+









-
+







	  (db:test-get-rundir prev-testdat)) ;; )
	 (waivers     (if testconfig (configf:section-vars testconfig "waivers") '()))
	 (waiver-rx   (regexp "^(\\S+)\\s+(.*)$"))
	 (diff-rule   "diff %file1% %file2%")
	 (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html"))
    (if (not (file-exists? test-rundir))
	(begin
	  (debug:print 0 #f "ERROR: test run directory is gone, cannot propagate waiver")
	  (debug:print 0 *default-log-port* "ERROR: test run directory is gone, cannot propagate waiver")
	  #f)
	(begin
	  (push-directory test-rundir)
	  (let ((result (if (null? waivers)
			    #f
			    (let loop ((hed (car waivers))
				       (tal (cdr waivers)))
			      (debug:print 0 #f "INFO: Applying waiver rule \"" hed "\"")
			      (debug:print 0 *default-log-port* "INFO: Applying waiver rule \"" hed "\"")
			      (let* ((waiver      (configf:lookup testconfig "waivers" hed))
				     (wparts      (if waiver (string-match waiver-rx waiver) #f))
				     (waiver-rule (if wparts (cadr wparts)  #f))
				     (waiver-glob (if wparts (caddr wparts) #f))
				     (logpro-file (if waiver
						      (let ((fname (conc hed ".logpro")))
							(if (file-exists? fname)
							    fname 
							    (begin
							      (debug:print 0 #f "INFO: No logpro file " fname " falling back to diff")
							      (debug:print 0 *default-log-port* "INFO: No logpro file " fname " falling back to diff")
							      #f)))
						      #f))
				     ;; if rule by name of waiver-rule is found in testconfig - use it
				     ;; else if waivername.logpro exists use logpro-rule
				     ;; else default to diff-rule
				     (rule-string (let ((rule (configf:lookup testconfig "waiver_rules" waiver-rule)))
						    (if rule
							rule
							(if logpro-file
							    logpro-rule
							    (begin
							      (debug:print 0 #f "INFO: No logpro file " logpro-file " found, using diff rule")
							      (debug:print 0 *default-log-port* "INFO: No logpro file " logpro-file " found, using diff rule")
							      diff-rule)))))
				     ;; (string-substitute "%file1%" "foofoo.txt" "This is %file1% and so is this %file1%." #t)
				     (processed-cmd (string-substitute 
						     "%file1%" (conc test-rundir "/" waiver-glob)
						     (string-substitute
						      "%file2%" (conc prev-rundir "/" waiver-glob)
						      (string-substitute
						       "%waivername%" hed rule-string #t) #t) #t))
				     (res            #f))
				(debug:print 0 #f "INFO: waiver command is \"" processed-cmd "\"")
				(debug:print 0 *default-log-port* "INFO: waiver command is \"" processed-cmd "\"")
				(if (eq? (system processed-cmd) 0)
				    (if (null? tal)
					#t
					(loop (car tal)(cdr tal)))
				    #f))))))
	    (pop-directory)
	    result)))))
375
376
377
378
379
380
381
382

383
384
385
386
387
388
389
390
391
392
393
394
395

396
397
398
399
400
401
402
375
376
377
378
379
380
381

382
383
384
385
386
387
388
389
390
391
392
393
394

395
396
397
398
399
400
401
402







-
+












-
+







			  (rmt:get-previous-test-run-record run-id test-name item-path)
			  #f))
	 (waived   (if prev-test
		       (if prev-test ;; true if we found a previous test in this run series
			   (let ((prev-status  (db:test-get-status  prev-test))
				 (prev-state   (db:test-get-state   prev-test))
				 (prev-comment (db:test-get-comment prev-test)))
			     (debug:print 4 #f "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment)
			     (debug:print 4 *default-log-port* "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment)
			     (if (and (equal? prev-state  "COMPLETED")
				      (equal? prev-status "WAIVED"))
				 (if comment
				     comment
				     prev-comment) ;; waived is either the comment or #f
				 #f))
			   #f)
		       #f)))
    (if (and waived 
	     (tests:check-waiver-eligibility testdat prev-test))
	(set! real-status "WAIVED"))

    (debug:print 4 #f "real-status " real-status ", waived " waived ", status " status)
    (debug:print 4 *default-log-port* "real-status " real-status ", waived " waived ", status " status)

    ;; update the primary record IF state AND status are defined
    (if (and state status)
	(begin
	  (rmt:test-set-status-state run-id test-id real-status state (if waived waived comment))
	  (mt:process-triggers run-id test-id state real-status)))
    
421
422
423
424
425
426
427
428

429
430
431
432
433
434
435
421
422
423
424
425
426
427

428
429
430
431
432
433
434
435







-
+







	  (variable (hash-table-ref/default otherdat ":variable" ""))
	  (value    (hash-table-ref/default otherdat ":value"    #f))
	  (expected (hash-table-ref/default otherdat ":expected" #f))
	  (tol      (hash-table-ref/default otherdat ":tol"      #f))
	  (units    (hash-table-ref/default otherdat ":units"    ""))
	  (type     (hash-table-ref/default otherdat ":type"     ""))
	  (dcomment (hash-table-ref/default otherdat ":comment"  "")))
      (debug:print 4 #f 
      (debug:print 4 *default-log-port* 
		   "category: " category ", variable: " variable ", value: " value
		   ", expected: " expected ", tol: " tol ", units: " units)
      (if (and value expected tol) ;; all three required
	  (let ((dat (conc category ","
			   variable ","
			   value    ","
			   expected ","
463
464
465
466
467
468
469
470

471
472
473
474


475
476
477
478
479
480
481
463
464
465
466
467
468
469

470
471
472


473
474
475
476
477
478
479
480
481







-
+


-
-
+
+







	 (logf-info      (rmt:test-get-logfile-info run-id test-name))
	 (logf           (if logf-info (cadr logf-info) #f))
	 (path           (if logf-info (car  logf-info) #f)))
    ;; This query finds the path and changes the directory to it for the test
    (if (and (string? path)
	     (directory? path)) ;; can get #f here under some wierd conditions. why, unknown ...
	(begin
	  (debug:print 4 #f "Found path: " path)
	  (debug:print 4 *default-log-port* "Found path: " path)
	  (change-directory path))
	;; (set! outputfilename (conc path "/" outputfilename)))
	(debug:print 0 #f "ERROR: summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path))
    (debug:print 4 #f "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force)
	(debug:print 0 *default-log-port* "ERROR: summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path))
    (debug:print 4 *default-log-port* "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force)
    (if (or (equal? logf "logs/final.log")
	    (equal? logf outputfilename)
	    force)
	(let ((my-start-time (current-seconds))
	      (lockf         (conc outputfilename ".lock")))
	  (let loop ((have-lock  (common:simple-file-lock lockf)))
	    (if have-lock
577
578
579
580
581
582
583
584

585
586
587
588
589
590

591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608

609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625

626
627
628
629
630
631
632
577
578
579
580
581
582
583

584
585
586
587
588
589

590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607

608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624

625
626
627
628
629
630
631
632







-
+





-
+

















-
+
















-
+







;; (define (dcommon:process-steps-table steps);; db test-id #!key (work-area #f))
(define (tests:process-steps-table steps);; db test-id #!key (work-area #f))
;;  (let ((steps   (db:get-steps-for-test db test-id work-area: work-area)))
    ;; organise the steps for better readability
    (let ((res (make-hash-table)))
      (for-each 
       (lambda (step)
	 (debug:print 6 #f "step=" 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 Comment
			(vector (tdb:step-get-stepname step) ""   "" ""     ""        ""     ""))))
	   (debug:print 6 #f "record(before) = " record 
	   (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 #f "record[1]=" (vector-ref record 1) 
				      (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)))
	      (if (> (string-length (tdb:step-get-comment step))
		     0)
		  (vector-set! record 6 (tdb:step-get-comment 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))
	      (vector-set! record 6 (tdb:step-get-comment step))))
	   (hash-table-set! res (tdb:step-get-stepname step) record)
	   (debug:print 6 #f "record(after)  = " 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)
820
821
822
823
824
825
826
827

828
829
830
831
832
833
834
820
821
822
823
824
825
826

827
828
829
830
831
832
833
834







-
+







  
;; sort tests by priority and waiton
;; Move test specific stuff to a test unit FIXME one of these days
(define (tests:sort-by-priority-and-waiton test-records)
  (let* ((mungepriority (lambda (priority)
			  (if priority
			      (let ((tmp (any->number priority)))
				(if tmp tmp (begin (debug:print 0 #f "ERROR: bad priority value " priority ", using 0") 0)))
				(if tmp tmp (begin (debug:print 0 *default-log-port* "ERROR: bad priority value " priority ", using 0") 0)))
			      0)))
	 (all-tests      (hash-table-keys test-records))
	 (all-waited-on  (let loop ((hed (car all-tests))
				    (tal (cdr all-tests))
				    (res '()))
			   (let* ((trec    (hash-table-ref test-records hed))
				  (waitons (or (tests:testqueue-get-waitons trec) '())))
845
846
847
848
849
850
851
852

853
854
855
856

857
858
859

860
861
862
863

864
865
866
867

868
869
870
871

872
873
874
875
876

877
878
879
880
881
882
883
845
846
847
848
849
850
851

852
853
854
855

856
857
858

859
860
861
862

863
864
865
866

867
868
869
870

871
872
873
874
875

876
877
878
879
880
881
882
883







-
+



-
+


-
+



-
+



-
+



-
+




-
+







		   (b-config   (tests:testqueue-get-testconfig  b-record))
		   (a-raw-pri  (config-lookup a-config "requirements" "priority"))
		   (b-raw-pri  (config-lookup b-config "requirements" "priority"))
		   (a-priority (mungepriority a-raw-pri))
		   (b-priority (mungepriority b-raw-pri)))
	      (tests:testqueue-set-priority! a-record a-priority)
	      (tests:testqueue-set-priority! b-record b-priority)
	      ;; (debug:print 0 #f "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons)
	      ;; (debug:print 0 *default-log-port* "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons)
	      (cond
	       ;; is 
	       ((member a b-waitons)          ;; is b waiting on a?
		;; (debug:print 0 #f "case1")
		;; (debug:print 0 *default-log-port* "case1")
		#t)
	       ((member b a-waitons)          ;; is a waiting on b?
		;; (debug:print 0 #f "case2")
		;; (debug:print 0 *default-log-port* "case2")
		#f)
	       ((and (not (null? a-waitons))  ;; both have waitons - do not disturb
		     (not (null? b-waitons)))
		;; (debug:print 0 #f "case2.1")
		;; (debug:print 0 *default-log-port* "case2.1")
		#t)
	       ((and (null? a-waitons)        ;; no waitons for a but b has waitons
		     (not (null? b-waitons)))
		;; (debug:print 0 #f "case3")
		;; (debug:print 0 *default-log-port* "case3")
		#f)
	       ((and (not (null? a-waitons))  ;; a has waitons but b does not
		     (null? b-waitons)) 
		;; (debug:print 0 #f "case4")
		;; (debug:print 0 *default-log-port* "case4")
		#t)
	       ((not (eq? a-priority b-priority)) ;; use
		(> a-priority b-priority))
	       (else
		;; (debug:print 0 #f "case5")
		;; (debug:print 0 *default-log-port* "case5")
		(string>? a b))))))
	 
	 (sort-fn2
	  (lambda (a b)
	    (> (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records a)))
	       (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records b)))))))
    ;; (let ((dot-res (tests:run-dot (tests:tests->dot test-records) "plain")))
1035
1036
1037
1038
1039
1040
1041
1042

1043
1044
1045
1046
1047
1048
1049
1050
1051
1052

1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064

1065
1066
1067
1068
1069
1070
1071
1035
1036
1037
1038
1039
1040
1041

1042
1043
1044
1045
1046
1047
1048
1049
1050
1051

1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063

1064
1065
1066
1067
1068
1069
1070
1071







-
+









-
+











-
+







      (let loop ((hed (car test-names))
		 (tal (cdr test-names)))         ;; 'return-procs tells the config reader to prep running system but return a proc
	(debug:print-info 4 #f "hed=" hed " at top of loop")
	(let* ((config  (tests:get-testconfig hed all-tests-registry 'return-procs))
	       (waitons (let ((instr (if config 
					 (config-lookup config "requirements" "waiton")
					 (begin ;; No config means this is a non-existant test
					   (debug:print 0 #f "ERROR: non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.")
					   (debug:print 0 *default-log-port* "ERROR: non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.")
					     ""))))
			  (debug:print-info 8 #f "waitons string is " instr)
			  (string-split (cond
					 ((procedure? instr)
					  (let ((res (instr)))
					    (debug:print-info 8 #f "waiton procedure results in string " res " for test " hed)
					    res))
					 ((string? instr)     instr)
					 (else 
					  ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 #f "ERROR: something went wrong in processing waitons for test " hed)
					  ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 *default-log-port* "ERROR: something went wrong in processing waitons for test " hed)
					  ""))))))
	  (if (not config) ;; this is a non-existant test called in a waiton. 
	      (if (null? tal)
		  test-records
		  (loop (car tal)(cdr tal)))
	      (begin
		(debug:print-info 8 #f "waitons: " waitons)
		;; check for hed in waitons => this would be circular, remove it and issue an
		;; error
		(if (member hed waitons)
		    (begin
		      (debug:print 0 #f "ERROR: test " hed " has listed itself as a waiton, please correct this!")
		      (debug:print 0 *default-log-port* "ERROR: test " hed " has listed itself as a waiton, please correct this!")
		      (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))))
		
		;; (items   (items:get-items-from-config config)))
		(if (not (hash-table-ref/default test-records hed #f))
		    (hash-table-set! test-records
				     hed (vector hed     ;; 0
						 config  ;; 1
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170



1171
1172

1173
1174
1175
1176
1177
1178
1179
1161
1162
1163
1164
1165
1166
1167



1168
1169
1170
1171

1172
1173
1174
1175
1176
1177
1178
1179







-
-
-
+
+
+

-
+







	 (begin
	   (print-call-chain (current-error-port))
	   (debug:print-info 0 #f "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 0 #f "ERROR: tried for over a minute to update meta info and failed. Giving up")
	   (debug:print 0 #f "EXCEPTION: database probably overloaded or unreadable.")
	   (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn))
	   (debug:print 0 *default-log-port* "ERROR: 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))
	   (print "exn=" (condition->list exn))
	   (debug:print 0 #f " status:  " ((condition-property-accessor 'sqlite3 'status) 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)
  )))
	 
;;======================================================================
;; A R C H I V I N G
;;======================================================================