Megatest

Diff
Login

Differences From Artifact [1caedc7eff]:

To Artifact [a478090184]:


68
69
70
71
72
73
74
75

76
77
78
79
80
81
82
83
84
85

86
87

88

89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107


108
109
110

111
112
113
114
115
116
117
68
69
70
71
72
73
74

75
76
77
78
79
80
81
82
83
84

85
86
87
88

89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106


107
108
109
110

111
112
113
114
115
116
117
118







-
+









-
+


+
-
+

















-
-
+
+


-
+







	       (debug:print-info 1 "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second)
	       #t)
	     #f))))

;; if a server is either running or in the process of starting call client:setup
;; else return #f to let the calling proc know that there is no server available
;;
(define (rmt:get-connection-info run-id #!key (remote #f))
(define (rmt:get-connection-info run-id area-dat #!key (remote #f))
  (let ((cinfo (common:get-remote remote run-id)))
    (if cinfo
	cinfo
	;; NB// can cache the answer for server running for 10 seconds ...
	;;  ;; (and (not (rmt:write-frequency-over-limit? cmd run-id))
	(if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)
	    (client:setup run-id remote: remote)
	    #f))))

(define (rmt:discard-old-connections)
(define (rmt:discard-old-connections area-dat)
  ;; clean out old connections
  (mutex-lock! *db-multi-sync-mutex*)
  (let ((remote      (megatest:area-remote area-dat))
  (let ((expire-time (- (current-seconds) (server:get-timeout) 10))) ;; don't forget the 10 second margin
	(expire-time (- (current-seconds) (server:get-timeout area-dat) 10))) ;; don't forget the 10 second margin
    (for-each 
     (lambda (run-id)
       (let ((connection (common:get-remote remote run-id)))
         (if (and (vector? connection)
        	  (< (http-transport:server-dat-get-last-access connection) expire-time))
             (begin
               (debug:print-info 0 "Discarding connection to server for run-id " run-id ", too long between accesses")
               ;; SHOULD CLOSE THE CONNECTION HERE
	       (case *transport-type*
		 ((nmsg)(nn-close (http-transport:server-dat-get-socket 
				   (common:get-remote remote run-id)))))
               (common:del-remote! remote run-id)))))
     (common:get-remote-all remote)))
  (mutex-unlock! *db-multi-sync-mutex*))

(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id

(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(remote #f)) ;; start attemptnum at 1 so the modulo below works as expected
  (rmt:discard-old-connections)
(define (rmt:send-receive cmd rid params area-dat #!key (attemptnum 1)(remote #f)) ;; start attemptnum at 1 so the modulo below works as expected
  (rmt:discard-old-connections area-dat)
  ;; (mutex-lock! *send-receive-mutex*)
  (let* ((run-id          (if rid rid 0))
	 (connection-info (rmt:get-connection-info run-id)))
	 (connection-info (rmt:get-connection-info run-id area-dat)))
    ;; the nmsg method does the encoding under the hood (the http method should be changed to do this also)
    (if connection-info
	;; use the server if have connection info
	(let* ((dat     (case *transport-type*
			  ((http)(condition-case
				  (http-transport:client-api-send-receive run-id connection-info cmd params)
				  ((commfail)(vector #f "communications fail"))
142
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
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







-
+














-
+

-
-
+
+




-
+







		;; (nmsg-transport:client-api-send-receive run-id connection-info cmd param remtries: (- remtries 1))))))

		;; no longer killing the server in http-transport:client-api-send-receive
		;; may kill it here but what are the criteria?
		;; start with three calls then kill server
		;; (if (eq? attemptnum 3)(tasks:kill-server-run-id run-id))
		;; (thread-sleep! 2)
		(rmt:send-receive cmd run-id params attemptnum: (+ attemptnum 1)))))
		(rmt:send-receive cmd run-id params area-dat attemptnum: (+ attemptnum 1)))))
	;; no connection info? try to start a server, or access locally if no
	;; server and the query is read-only
	;;
	;; Note: The tasks db was checked for a server in starting mode in the rmt:get-connection-info call
	;;
	(if (and (< attemptnum 15)
		 (member cmd api:write-queries))
	    (let ((faststart (configf:lookup *configdat* "server" "faststart")))
	      (common:del-remote! remote run-id)
	      ;; (mutex-unlock! *send-receive-mutex*)
	      (if (and faststart (equal? faststart "no"))
		  (begin
		    (tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id 10)
		    (thread-sleep! (random 5)) ;; give some time to settle and minimize collison?
		    (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
		    (rmt:send-receive cmd rid params area-dat attemptnum: (+ attemptnum 1)))
		  (begin
		    (server:kind-run run-id)
		    (rmt:open-qry-close-locally cmd run-id params))))
		    (server:kind-run run-id area-dat)
		    (rmt:open-qry-close-locally cmd run-id params area-dat))))
	    (begin
	      ;; (debug:print 0 "ERROR: Communication failed!")
	      ;; (mutex-unlock! *send-receive-mutex*)
	      ;; (exit)
	      (rmt:open-qry-close-locally cmd run-id params)
	      (rmt:open-qry-close-locally cmd run-id params area-dat)
	      )))))

(define (rmt:update-db-stats run-id rawcmd params duration)
  (mutex-lock! *db-stats-mutex*)
  (handle-exceptions
   exn
   (begin
260
261
262
263
264
265
266
267

268
269
270
271
272
273
274
261
262
263
264
265
266
267

268
269
270
271
272
273
274
275







-
+







		(mutex-lock! *db-multi-sync-mutex*)
		;; (if (not (hash-table-ref/default *db-local-sync* run-id #f))
		;; just set it every time. Is a write more expensive than a read and does it matter?
		(hash-table-set! *db-local-sync* (or run-id 0) start-time) ;; the oldest "write"
		(mutex-unlock! *db-multi-sync-mutex*)))
	  res))))

(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params area-dat)
  (let* ((run-id   (if run-id run-id 0))
	 ;; (jparams  (db:obj->string params)) ;; (rmt:dat->json-str params))
	 (res  	   (handle-exceptions
		    exn
		    #f
		    (http-transport:client-api-send-receive run-id connection-info cmd params))))
;;		    ((commfail) (vector #f "communications fail")))))
298
299
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
355
356
357
358
359


360
361

362
363

364
365
366
367
368
369
370


371
372

373
374
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
403
404
405
406
407
408
409
410
411
412
413
414
415

416
417
418
419
420
421
422
299
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
355
356
357
358


359
360
361

362
363

364
365
366
367
368
369


370
371
372

373
374
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
403
404
405
406
407
408
409
410
411
412
413
414
415

416
417
418
419
420
421
422
423







-
+


-
+






-
+






-
-
+
+




-
-
+
+

-
-
+
+

-
+

-
+


-
-
+
+







-
-
+
+

-
-
+
+





-
-
+
+

-
+

-
+





-
-
+
+

-
+


-
+




-
-
+
+

-
-
+
+

-
+

-
+






-
-
+
+



-
+














-
+







;;======================================================================

;;======================================================================
;;  S E R V E R
;;======================================================================

(define (rmt:kill-server run-id)
  (rmt:send-receive 'kill-server run-id (list run-id)))
  (rmt:send-receive 'kill-server run-id (list run-id) area-dat))

(define (rmt:start-server run-id)
  (rmt:send-receive 'start-server 0 (list run-id)))
  (rmt:send-receive 'start-server 0 (list run-id) area-dat))

;;======================================================================
;;  M I S C
;;======================================================================

(define (rmt:login run-id)
  (rmt:send-receive 'login run-id (list *toppath* megatest-version run-id *my-client-signature*)))
  (rmt:send-receive 'login run-id (list *toppath* megatest-version run-id *my-client-signature*) area-dat))

;; This login does no retries under the hood - it acts a bit like a ping.
;; Deprecated for nmsg-transport.
;;
(define (rmt:login-no-auto-client-setup connection-info run-id)
  (case *transport-type*
    ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*)))
    ((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*)))))
    ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*) area-dat))
    ((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*) area-dat))))

;; hand off a call to one of the db:queries statements
;; added run-id to make looking up the correct db possible 
;;
(define (rmt:general-call stmtname run-id . params)
  (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params)))
(define (rmt:general-call stmtname run-id area-dat . params)
  (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params) area-dat))

(define (rmt:sync-inmem->db run-id)
  (rmt:send-receive 'sync-inmem->db run-id '()))
(define (rmt:sync-inmem->db run-id area-dat)
  (rmt:send-receive 'sync-inmem->db run-id '() area-dat))

(define (rmt:sdb-qry qry val run-id)
(define (rmt:sdb-qry qry val run-id area-dat)
  ;; add caching if qry is 'getid or 'getstr
  (rmt:send-receive 'sdb-qry run-id (list qry val)))
  (rmt:send-receive 'sdb-qry run-id (list qry val) area-dat))

;; NOT COMPLETED
(define (rmt:runtests user run-id testpatt params)
  (rmt:send-receive 'runtests run-id testpatt))
(define (rmt:runtests user run-id testpatt params area-dat)
  (rmt:send-receive 'runtests run-id testpatt area-dat))

;;======================================================================
;;  K E Y S 
;;======================================================================

;; These require run-id because the values come from the run!
;;
(define (rmt:get-key-val-pairs run-id)
  (rmt:send-receive 'get-key-val-pairs run-id (list run-id)))
(define (rmt:get-key-val-pairs run-id area-dat)
  (rmt:send-receive 'get-key-val-pairs run-id (list run-id) area-dat))

(define (rmt:get-keys)
  (rmt:send-receive 'get-keys #f '()))
(define (rmt:get-keys area-dat)
  (rmt:send-receive 'get-keys #f '() area-dat))

;;======================================================================
;;  T E S T S
;;======================================================================

(define (rmt:get-test-id run-id testname item-path)
  (rmt:send-receive 'get-test-id run-id (list run-id testname item-path)))
(define (rmt:get-test-id run-id testname item-path area-dat)
  (rmt:send-receive 'get-test-id run-id (list run-id testname item-path) area-dat))

(define (rmt:get-test-info-by-id run-id test-id)
(define (rmt:get-test-info-by-id run-id test-id area-dat)
  (if (and (number? run-id)(number? test-id))
      (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id))
      (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id) area-dat)
      (begin
	(debug:print 0 "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
	(print-call-chain (current-error-port))
	#f)))

(define (rmt:test-get-rundir-from-test-id run-id test-id)
  (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))
(define (rmt:test-get-rundir-from-test-id run-id test-id area-dat)
  (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id) area-dat))

(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
(define (rmt:open-test-db-by-test-id run-id test-id area-dat #!key (work-area #f))
  (let* ((test-path (if (string? work-area)
			work-area
			(rmt:test-get-rundir-from-test-id run-id test-id))))
			(rmt:test-get-rundir-from-test-id run-id test-id area-dat))))
    (debug:print 3 "TEST PATH: " test-path)
    (open-test-db test-path)))

;; WARNING: This currently bypasses the transaction wrapped writes system
(define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
  (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment)))
(define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment area-dat)
  (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment) area-dat))

(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus)
  (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus)))
(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus area-dat)
  (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus) area-dat))

(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals)
(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals area-dat)
  (if (number? run-id)
      (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals))
      (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) area-dat)
      (begin
	(debug:print "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id)
	(print-call-chain (current-error-port))
	'())))

;; get stuff via synchash 
(define (rmt:synchash-get run-id proc synckey keynum params)
  (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params)))
(define (rmt:synchash-get run-id proc synckey keynum params area-dat)
  (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params) area-dat))

;; IDEA: Threadify these - they spend a lot of time waiting ...
;;
(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in area-dat)
  (let ((multi-run-mutex (make-mutex))
	(run-id-list (if run-ids
			 run-ids
			 (rmt:get-all-run-ids)))
	(result      '()))
    (if (null? run-id-list)
	'()
	(let loop ((hed     (car run-id-list))
		   (tal     (cdr run-id-list))
		   (threads '()))
	  (if (> (length threads) 5)
	      (loop hed tal (filter (lambda (th)(not (member (thread-state th) '(terminated dead)))) threads))
	      (let* ((newthread (make-thread
				 (lambda ()
				   (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in))))
				   (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in) area-dat)))
				     (if (list? res)
					 (begin
					   (mutex-lock! multi-run-mutex)
					   (set! result (append result res))
					   (mutex-unlock! multi-run-mutex))
					 (debug:print 0 "ERROR: get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in))))
				 (conc "multi-run-thread for run-id " hed)))
434
435
436
437
438
439
440
441
442


443
444
445
446
447
448
449
450


451
452
453


454
455
456
457
458
459


460
461
462


463
464
465


466
467
468


469
470
471


472
473
474


475
476
477


478
479
480


481
482
483
484
485


486
487
488

489
490
491
492


493
494
495


496
497
498


499
500
501
502
503


504
505
506


507
508
509


510
511
512


513
514
515


516
517
518
519
520
521
522


523
524
525
526


527
528
529


530
531
532


533
534
535


536
537
538


539
540
541


542
543
544


545
546
547


548
549
550


551
552
553
554


555
556
557


558
559
560


561
562
563


564
565
566
567



568
569
570
571
572
573
574
575


576
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
435
436
437
438
439
440
441


442
443
444
445
446
447
448
449


450
451
452


453
454
455
456
457
458


459
460
461


462
463
464


465
466
467


468
469
470


471
472
473


474
475
476


477
478
479


480
481
482
483
484


485
486
487
488

489
490
491


492
493
494


495
496
497


498
499
500
501
502


503
504
505


506
507
508


509
510
511


512
513
514


515
516
517
518
519
520
521


522
523
524
525


526
527
528


529
530
531


532
533
534


535
536
537


538
539
540


541
542
543


544
545
546


547
548
549


550
551
552
553


554
555
556


557
558
559


560
561
562


563
564
565



566
567
568
569
570
571
572
573
574


575
576
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







-
-
+
+






-
-
+
+

-
-
+
+




-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+



-
-
+
+


-
+


-
-
+
+

-
-
+
+

-
-
+
+



-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+





-
-
+
+


-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+


-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+

-
-
-
+
+
+






-
-
+
+

-
+







-
-
-
+
+
+




-
+






-
+







;;   (let ((run-id-list (if run-ids
;; 			 run-ids
;; 			 (rmt:get-all-run-ids))))
;;     (apply append (map (lambda (run-id)
;; 			 (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in)))
;; 		       run-id-list))))

(define (rmt:delete-test-records run-id test-id)
  (rmt:send-receive 'delete-test-records run-id (list run-id test-id)))
(define (rmt:delete-test-records run-id test-id area-dat)
  (rmt:send-receive 'delete-test-records run-id (list run-id test-id) area-dat))

;; This is not needed as test steps are deleted on test delete call
;;
;; (define (rmt:delete-test-step-records run-id test-id)
;;   (rmt:send-receive 'delete-test-step-records run-id (list run-id test-id)))

(define (rmt:test-set-status-state run-id test-id status state msg)
  (rmt:send-receive 'test-set-status-state run-id (list run-id test-id status state msg)))
(define (rmt:test-set-status-state run-id test-id status state msg area-dat)
  (rmt:send-receive 'test-set-status-state run-id (list run-id test-id status state msg) area-dat))

(define (rmt:test-toplevel-num-items run-id test-name)
  (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name)))
(define (rmt:test-toplevel-num-items run-id test-name area-dat)
  (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name) area-dat))

;; (define (rmt:get-previous-test-run-record run-id test-name item-path)
;;   (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path)))

(define (rmt:get-matching-previous-test-run-records run-id test-name item-path)
  (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path)))
(define (rmt:get-matching-previous-test-run-records run-id test-name item-path area-dat)
  (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path) area-dat))

(define (rmt:test-get-logfile-info run-id test-name)
  (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name)))
(define (rmt:test-get-logfile-info run-id test-name area-dat)
  (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name) area-dat))

(define (rmt:test-get-records-for-index-file run-id test-name)
  (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name)))
(define (rmt:test-get-records-for-index-file run-id test-name area-dat)
  (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name) area-dat))

(define (rmt:get-testinfo-state-status run-id test-id)
  (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id)))
(define (rmt:get-testinfo-state-status run-id test-id area-dat)
  (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id) area-dat))

(define (rmt:test-set-log! run-id test-id logf)
  (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id)))
(define (rmt:test-set-log! run-id test-id logf area-dat)
  (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id area-dat)))

(define (rmt:test-set-top-process-pid run-id test-id pid)
  (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid)))
(define (rmt:test-set-top-process-pid run-id test-id pid area-dat)
  (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid) area-dat))

(define (rmt:test-get-top-process-pid run-id test-id)
  (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id)))
(define (rmt:test-get-top-process-pid run-id test-id area-dat)
  (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id) area-dat))

(define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)
  (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt)))
(define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt area-dat)
  (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt) area-dat))

;; NOTE: This will open and access ALL run databases. 
;;
(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
  (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)))
(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname area-dat)
  (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt area-dat)))
    (apply append 
	   (map (lambda (run-id)
		  (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname)))
		  (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname) area-dat))
	   run-ids))))

(define (rmt:get-run-ids-matching keynames target res)
  (rmt:send-receive #f 'get-run-ids-matching (list keynames target res)))
(define (rmt:get-run-ids-matching keynames target res area-dat)
  (rmt:send-receive #f 'get-run-ids-matching (list keynames target res) area-dat) area-dat)

(define (rmt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal)))
  (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-item-path mode)))
(define (rmt:get-prereqs-not-met run-id waitons ref-item-path area-dat #!key (mode '(normal)))
  (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-item-path mode) area-dat))

(define (rmt:get-count-tests-running-for-run-id run-id)
  (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))
(define (rmt:get-count-tests-running-for-run-id run-id area-dat)
  (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id) area-dat))

;; Statistical queries

(define (rmt:get-count-tests-running run-id)
  (rmt:send-receive 'get-count-tests-running run-id (list run-id)))
(define (rmt:get-count-tests-running run-id area-dat)
  (rmt:send-receive 'get-count-tests-running run-id (list run-id) area-dat))

(define (rmt:get-count-tests-running-for-testname run-id testname)
  (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname)))
(define (rmt:get-count-tests-running-for-testname run-id testname area-dat)
  (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname) area-dat))

(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)
  (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup)))
(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup area-dat)
  (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup) area-dat))

(define (rmt:roll-up-pass-fail-counts run-id test-name item-path status)
  (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path status)))
(define (rmt:roll-up-pass-fail-counts run-id test-name item-path status area-dat)
  (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path status) area-dat))

(define (rmt:update-pass-fail-counts run-id test-name)
  (rmt:general-call 'update-fail-pass-counts run-id (list run-id test-name run-id test-name run-id test-name)))
(define (rmt:update-pass-fail-counts run-id test-name area-dat)
  (rmt:general-call 'update-fail-pass-counts run-id (list run-id test-name run-id test-name run-id test-name) area-dat))

;;======================================================================
;;  R U N S
;;======================================================================

(define (rmt:get-run-info run-id)
  (rmt:send-receive 'get-run-info run-id (list run-id)))
(define (rmt:get-run-info run-id area-dat)
  (rmt:send-receive 'get-run-info run-id (list run-id) area-dat))

;; Use the special run-id == #f scenario here since there is no run yet
(define (rmt:register-run keyvals runname state status user)
  (rmt:send-receive 'register-run #f (list keyvals runname state status user)))
(define (rmt:register-run keyvals runname state status user area-dat)
  (rmt:send-receive 'register-run #f (list keyvals runname state status user) area-dat))
    
(define (rmt:get-run-name-from-id run-id)
  (rmt:send-receive 'get-run-name-from-id run-id (list run-id)))
(define (rmt:get-run-name-from-id run-id area-dat)
  (rmt:send-receive 'get-run-name-from-id run-id (list run-id) area-dat))

(define (rmt:delete-run run-id)
  (rmt:send-receive 'delete-run run-id (list run-id)))
(define (rmt:delete-run run-id area-dat)
  (rmt:send-receive 'delete-run run-id (list run-id) area-dat))

(define (rmt:delete-old-deleted-test-records)
  (rmt:send-receive 'delete-old-deleted-test-records #f '()))
(define (rmt:delete-old-deleted-test-records area-dat)
  (rmt:send-receive 'delete-old-deleted-test-records #f '() area-dat))

(define (rmt:get-runs runpatt count offset keypatts)
  (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))
(define (rmt:get-runs runpatt count offset keypatts area-dat)
  (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts) area-dat))

(define (rmt:get-runs runpatt count offset keypatts)
  (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))
(define (rmt:get-runs runpatt count offset keypatts area-dat)
  (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts) area-dat))

(define (rmt:get-all-run-ids)
  (rmt:send-receive 'get-all-run-ids #f '()))
(define (rmt:get-all-run-ids area-dat)
  (rmt:send-receive 'get-all-run-ids #f '() area-dat))

(define (rmt:get-prev-run-ids run-id)
  (rmt:send-receive 'get-prev-run-ids #f (list run-id)))
(define (rmt:get-prev-run-ids run-id area-dat)
  (rmt:send-receive 'get-prev-run-ids #f (list run-id) area-dat))

(define (rmt:lock/unlock-run run-id lock unlock user)
  (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user)))
(define (rmt:lock/unlock-run run-id lock unlock user area-dat)
  (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user) area-dat))

;; set/get status
(define (rmt:get-run-status run-id)
  (rmt:send-receive 'get-run-status #f (list run-id)))
(define (rmt:get-run-status run-id area-dat)
  (rmt:send-receive 'get-run-status #f (list run-id) area-dat))

(define (rmt:set-run-status run-id run-status #!key (msg #f))
  (rmt:send-receive 'set-run-status #f (list run-id run-status msg)))
(define (rmt:set-run-status run-id run-status area-dat #!key (msg #f))
  (rmt:send-receive 'set-run-status #f (list run-id run-status msg) area-dat))

(define (rmt:update-run-event_time run-id)
  (rmt:send-receive 'update-run-event_time #f (list run-id)))
(define (rmt:update-run-event_time run-id area-dat)
  (rmt:send-receive 'update-run-event_time #f (list run-id) area-dat))

(define (rmt:get-runs-by-patt  keys runnamepatt targpatt offset limit)
  (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit)))
(define (rmt:get-runs-by-patt  keys runnamepatt targpatt offset limit area-dat)
  (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit) area-dat))

(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
  (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime))
      (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))))
(define (rmt:find-and-mark-incomplete run-id ovr-deadtime area-dat)
  (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime) area-dat)
      (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime) area-dat)))

;;======================================================================
;; M U L T I R U N   Q U E R I E S
;;======================================================================

;; Need to move this to multi-run section and make associated changes
(define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f))
  (let ((run-ids (rmt:get-all-run-ids)))
(define (rmt:find-and-mark-incomplete-all-runs area-dat #!key (ovr-deadtime #f))
  (let ((run-ids (rmt:get-all-run-ids area-dat)))
    (for-each (lambda (run-id)
	       (rmt:find-and-mark-incomplete run-id ovr-deadtime))
	       (rmt:find-and-mark-incomplete run-id ovr-deadtime area-dat))
	     run-ids)))

;; get the previous record for when this test was run where all keys match but runname
;; returns #f if no such test found, returns a single test record if found
;; 
;; Run this at the client end since we have to connect to multiple run-id dbs
;;
(define (rmt:get-previous-test-run-record run-id test-name item-path)
  (let* ((keyvals (rmt:get-key-val-pairs run-id))
	 (keys    (rmt:get-keys))
(define (rmt:get-previous-test-run-record run-id test-name item-path area-dat)
  (let* ((keyvals (rmt:get-key-val-pairs run-id area-dat))
	 (keys    (rmt:get-keys area-dat))
	 (selstr  (string-intersperse  keys ","))
	 (qrystr  (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
    (if (not keyvals)
	#f
	(let ((prev-run-ids (rmt:get-prev-run-ids run-id)))
	(let ((prev-run-ids (rmt:get-prev-run-ids run-id area-dat)))
	  ;; for each run starting with the most recent look to see if there is a matching test
	  ;; if found then return that matching test record
	  (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
	  (if (null? prev-run-ids) #f
	      (let loop ((hed (car prev-run-ids))
			 (tal (cdr prev-run-ids)))
		(let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f)))
		(let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f area-dat)))
		  (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
		  (if (and (null? results)
			   (not (null? tal)))
		      (loop (car tal)(cdr tal))
		      (if (null? results) #f
			  (car results))))))))))

616
617
618
619
620
621
622
623

624
625
626
627
628
629

630
631
632


633
634
635
636
637
638
639


640
641

642
643
644
645


646
647
648


649
650
651


652
653
654


655
656
657


658
659
660
661
662
663
664


665
666
667


668
669
670


671
672
673
674
675
676
677


678
679
680


681
682
683


684
685
686


687
688
689


690
691
692


617
618
619
620
621
622
623

624
625
626
627
628
629

630
631


632
633
634
635
636
637
638


639
640
641

642
643
644


645
646
647


648
649
650


651
652
653


654
655
656


657
658
659
660
661
662
663


664
665
666


667
668
669


670
671
672
673
674
675
676


677
678
679


680
681
682


683
684
685


686
687
688


689
690
691


692
693







-
+





-
+

-
-
+
+





-
-
+
+

-
+


-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+





-
-
+
+

-
-
+
+

-
-
+
+





-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+

-
-
+
+
;; If not given the work area
;;  1. Do a remote call to get the test path
;;  2. Continue as above
;; 
;;(define (rmt:get-steps-for-test run-id test-id)
;;  (rmt:send-receive 'get-steps-data run-id (list test-id)))

(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile)
(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile area-dat)
  (let* ((state     (items:check-valid-items "state" state-in))
	 (status    (items:check-valid-items "status" status-in)))
    (if (or (not state)(not status))
	(debug:print 3 "WARNING: Invalid " (if status "status" "state")
		     " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
    (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile))))
    (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile) area-dat)))

(define (rmt:get-steps-for-test run-id test-id)
  (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id)))
(define (rmt:get-steps-for-test run-id test-id area-dat)
  (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id) area-dat))

;;======================================================================
;;  T E S T   D A T A 
;;======================================================================

(define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) 
  (let ((tdb  (rmt:open-test-db-by-test-id run-id test-id work-area: work-area)))
(define (rmt:read-test-data run-id test-id categorypatt area-dat #!key (work-area #f)) 
  (let ((tdb  (rmt:open-test-db-by-test-id run-id test-id area-dat work-area: work-area)))
    (if tdb
	(tdb:read-test-data tdb test-id categorypatt)
	(tdb:read-test-data tdb test-id categorypatt area-dat)
	'())))

(define (rmt:testmeta-add-record testname)
  (rmt:send-receive 'testmeta-add-record #f (list testname)))
(define (rmt:testmeta-add-record testname area-dat)
  (rmt:send-receive 'testmeta-add-record #f (list testname) area-dat))

(define (rmt:testmeta-get-record testname)
  (rmt:send-receive 'testmeta-get-record #f (list testname)))
(define (rmt:testmeta-get-record testname area-dat)
  (rmt:send-receive 'testmeta-get-record #f (list testname) area-dat))

(define (rmt:testmeta-update-field test-name fld val)
  (rmt:send-receive 'testmeta-update-field #f (list test-name fld val)))
(define (rmt:testmeta-update-field test-name fld val area-dat)
  (rmt:send-receive 'testmeta-update-field #f (list test-name fld val) area-dat))

(define (rmt:test-data-rollup run-id test-id status)
  (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status)))
(define (rmt:test-data-rollup run-id test-id status area-dat)
  (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status) area-dat))

(define (rmt:csv->test-data run-id test-id csvdata)
  (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata)))
(define (rmt:csv->test-data run-id test-id csvdata area-dat)
  (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata) area-dat))

;;======================================================================
;;  T A S K S
;;======================================================================

(define (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt)
  (rmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt)))
(define (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt area-dat)
  (rmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt) area-dat))

(define (rmt:tasks-add action owner target runname testpatt params)
  (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params)))
(define (rmt:tasks-add action owner target runname testpatt params area-dat)
  (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params) area-dat))

(define (rmt:tasks-set-state-given-param-key param-key new-state)
  (rmt:send-receive 'tasks-set-state-given-param-key #f (list  param-key new-state)))
(define (rmt:tasks-set-state-given-param-key param-key new-state area-dat)
  (rmt:send-receive 'tasks-set-state-given-param-key #f (list  param-key new-state) area-dat))

;;======================================================================
;; A R C H I V E S
;;======================================================================

(define (rmt:archive-get-allocations  testname itempath dneeded)
  (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded)))
(define (rmt:archive-get-allocations  testname itempath dneeded area-dat)
  (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded) area-dat))

(define (rmt:archive-register-block-name bdisk-id archive-path)
  (rmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path)))
(define (rmt:archive-register-block-name bdisk-id archive-path area-dat)
  (rmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path) area-dat))

(define (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
  (rmt:send-receive 'archive-allocate-test-to-block #f (list  block-id testsuite-name areakey)))
(define (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey area-dat)
  (rmt:send-receive 'archive-allocate-test-to-block #f (list  block-id testsuite-name areakey) area-dat))

(define (rmt:archive-register-disk bdisk-name bdisk-path df)
  (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df)))
(define (rmt:archive-register-disk bdisk-name bdisk-path df area-dat)
  (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df) area-dat))

(define (rmt:test-set-archive-block-id run-id test-id archive-block-id)
  (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id)))
(define (rmt:test-set-archive-block-id run-id test-id archive-block-id area-dat)
  (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id) area-dat))

(define (rmt:test-get-archive-block-info archive-block-id)
  (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id)))
(define (rmt:test-get-archive-block-info archive-block-id area-dat)
  (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id) area-dat))