Megatest

Changes On Branch f8b71f1e3fe0d364
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Hide Diff Patch Side-by-Side Diff

Changes In Branch areas-work-merge Excluding Merge-Ins

This is equivalent to a diff from 65fadb2649 to f8b71f1e3f

2017-11-17
16:49
Merged from f8b7 - fails Leaf check-in: 1cc36f7d8a user: mrwellan tags: v1.64-recover-areas-dashboard (unpublished)
16:19
Merged f9b5 Leaf check-in: f8b71f1e3f user: mrwellan tags: areas-work-merge (unpublished)
16:10
Merged 1f5e check-in: b289de052e user: mrwellan tags: areas-work-merge (unpublished)
15:52
Pulled in da67 check-in: 6db9365e99 user: mrwellan tags: areas-work-merge (unpublished)
14:24
Attempted merge Leaf check-in: 3436c3834f user: mrwellan tags: attempted-merge (unpublished)
2017-11-16
17:07
Fix for fixme-matt bug Closed-Leaf check-in: 65fadb2649 user: mrwellan tags: Moved fix to be against the fixme-matt commit
16:21
Deconstructing changes make for areas-dashboard to isolate catastrophic bug in fixme-matt Closed-Leaf check-in: 436bc0ac0f user: mrwellan tags: v1.64-areas-dashboard-bug-fix
2017-08-28
21:25
All rmt: calls replaced with db: calls using the dbstructs from areas. check-in: f9b5189ffe user: matt tags: v1.64-areas-dashboard
2017-08-14
01:03
Partially removed global *db-cache-path* (might need to add it back for performance reasons, used in rmt: calls.) Modified common:get-db-tmp-area to get info from dbstruct instead of globals. Added proc to open area dbs Gutted dboard:areas-update-tree. Does only areas now. First pass on some refactoring in db:get-db, db:open-db, db:dbfile-path (these need to be reduced to one function). check-in: 37c6122258 user: matt tags: v1.64-areas-dashboard, fixme-matt

Added codescanlib.scm version [85429a3289]. 

































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
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
119
120
121
122
123
124
125
126
127

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+


;; gotta compile with csc, doesn't work with csi -s for whatever reason

(use srfi-69)
(use matchable)
(use utils)
(use ports)
(use extras)
(use srfi-1)
(use posix)
(use srfi-12)

;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> )
(define (load-scm-file scm-file)
  ;;(print "load "scm-file)
  (handle-exceptions
   exn
   '()
   (with-input-from-string
       (conc "("
             (with-input-from-file scm-file read-all)
             ")" )
     read)))

;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
;;   -- be advised:
;;      * this may be fooled by macros, since this code does not take them into account.
;;      * this code does only checks for form (define (<procname> ... ) <body>)
;;           so it excludes from reckoning
;;               - generated functions, as in things like foo-set! from defstructs,
;;               - define-inline, (
;;               - define procname (lambda ..
;;               - etc...
(define (get-toplevel-procs+file+args+body filename)
  (let* ((scm-tree (load-scm-file filename))
         (procs
          (filter identity
                  (map
                   (match-lambda 
                    [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
                    [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
                    [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
                    [('define (defname args ...) body ...) ;; match (define (procname <args>) <body>)
                     (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
                         (list defname filename args body)
                         #f)]
                    [else #f] ) scm-tree))))
    procs))


;; given a sexp, return a flat lost of atoms in that sexp
(define (get-atoms-in-body body)
  (cond
   ((null? body) '())
   ((atom? body) (list body))
   (else
    (apply append (map get-atoms-in-body body)))))

;;  given a file, return a list of procname, file, list of atoms in said procname
(define (get-procs+file+atoms file)
  (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
         (res
          (map
           (lambda (item)
             (let* ((proc (car item))
                    (file (cadr item))
                    (args (caddr item))
                    (body (cadddr item))
                    (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
               (list proc file atoms)))
           toplevel-proc-items)))
    res))

;; uniquify a list of atoms 
(define (unique-atoms lst)
  (let loop ((lst (flatten lst)) (res '()))
    (if (null? lst)
        (reverse res)
        (let ((c (car lst)))
          (loop (cdr lst) (if (member c res) res (cons c res)))))))

;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
;; returning alist mapping procname to procname that calls said procname
(define (get-callers-alist all-procs+file+calls)
  (let* ((all-procs (map car all-procs+file+calls))
         (caller-ht (make-hash-table))) 
    ;; let's cross reference with a hash table
    (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
    (for-each (lambda (item)
               (let* ((proc (car item))
                      (file (cadr item))
                      (calls (caddr item)))
                 (for-each (lambda (callee)
                             (hash-table-set! caller-ht callee
                                              (cons proc
                                                    (hash-table-ref caller-ht callee))))
                           calls)))
              all-procs+file+calls)
    (map (lambda (x)
           (let ((k (car x))
                 (r (unique-atoms (cdr x))))
             (cons k r)))                    
         (hash-table->alist caller-ht))))

;; create a handy cross-reference of callees to callers in the form of an alist.
(define (get-xref all-scm-files)
  (let* ((all-procs+file+atoms
          (apply append (map get-procs+file+atoms all-scm-files)))
         (all-procs (map car all-procs+file+atoms))
         (all-procs+file+calls  ; proc calls things in calls list
          (map (lambda (item)
                 (let* ((proc (car item))
                        (file (cadr item))
                        (atoms (caddr item))
                        (calls
                         (filter identity
                                 (map
                                  (lambda (x)
                                    (if (and ;; (not (equal? x proc))  ;; uncomment to prevent listing self
                                         (member x all-procs))
                                        x
                                        #f))
                                  atoms))))
                   (list proc file calls)))
               all-procs+file+atoms))
         (callers (get-callers-alist all-procs+file+calls))) 
    callers))








Modified common.scm
from [eb2e308b10]
to [95cb612a8f].




︙


638
639
640
641
642
643
644
645

646
647
648
649
650
651
652

638
639
640
641
642
643
644

645
646
647
648
649
650
651
652








-
+








(define common:get-area-name common:get-testsuite-name)

;; WARNING: This code falls back to using the global Megatest
;;          variable *toppath*
;; 
(define (common:get-db-tmp-area #!key (dbstruct #f))
  (if (and dbstruct (dbr:dbstruct-tmpdb-path dbstruct)) ;; *db-cache-path*
      (dbr:dbstruct-tmpdb-path) ;; *db-cache-path*
      (dbr:dbstruct-tmpdb-path dbstruct) ;; *db-cache-path*
      (let ((toppath (or (and dbstruct (dbr:dbstruct-area-path dbstruct)) *toppath*))
	    (tsname  (or (and dbstruct (dbr:dbstruct-area-name dbstruct))(common:get-testsuite-name))))
	(if toppath ;; common:get-create-writeable-dir
	    (handle-exceptions
		exn
		(begin
		  (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)




︙


1671
1672
1673
1674
1675
1676
1677
1678

1679
1680
1681
1682
1683
1684
1685

1671
1672
1673
1674
1675
1676
1677

1678
1679
1680
1681
1682
1683
1684
1685








-
+








;; check space in dbdir and in megatest dir
;; returns: ok/not dbspace required-space
;;
(define (common:check-db-dir-space)
  (let* ((required (string->number 
		    (or (configf:lookup *configdat* "setup" "dbdir-space-required")
			"100000")))
	 (dbdir    (common:get-db-tmp-area)) ;; (db:get-dbdir))
	 (dbdir    (common:get-db-tmp-area #f)) ;; (db:get-dbdir))
	 (tdbspace (common:check-space-in-dir dbdir required))
	 (mdbspace (common:check-space-in-dir *toppath* required)))
    (sort (list tdbspace mdbspace) (lambda (a b)
				     (< (cadr a)(cadr b))))))
    
;; check available space in dbdir, exit if insufficient
;;




︙







Modified dashboard-areas.scm
from [ac01c869cc]
to [c826774e24].



1
2
3
4
5
6
7
8
9
10

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28

29
30
31

32
33
34
35
36
37
38

1
2
3
4
5
6
7
8
9

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27

28
29
30

31
32
33
34
35
36
37
38










-
+

















-
+


-
+








;;======================================================================
;; AREAS
;;======================================================================

(define (dashboard:areas-summary-updater commondat tabdat tb cell-lookup run-matrix)
  ;; maps data from tabdat view-dat to the matrix
  ;; if input databases have changed, refresh view-dat
  ;; if filters have changed, refresh view-dat from input databases
  ;; if pivots  have changed, refresh view-dat from input databases
  (let* ((runs-hash    (dashboard:areas-get-runs-hash tabdat))
  (let* ((runs-hash    (dashboard:areas-get-runs-hash commondat tabdat))
	 (runs-header '("contour_name" "release" "iteration" "testsuite_mode" "id" "runname" "state" "status" "owner" "event_time"))
	 (tree-path    (dboard:tabdat-tree-path tabdat)))
    (dboard:areas-update-tree tabdat runs-hash runs-header tb)
    (print "Tree path: " tree-path)
    (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS
    (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
    (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES")

    ;; (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL")))
    (iup:attribute-set! run-matrix "NUMCOL" 10) ;; max-col ))
   
    ;; (let ((effective-max-row (if (< max-row max-visible) max-visible max-row)))
    ;; (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN")))
    (iup:attribute-set! run-matrix "NUMLIN" 10) ;; effective-max-row )))
    (iup:attribute-set! run-matrix "1:1" (conc tree-path))
    (iup:attribute-set! run-matrix "REDRAW" "ALL")))
  
  ;; (dashboard:areas-do-update-rundat tabdat) ;; )
  ;; (dashboard:areas-do-update-rundat commondat tabdat) ;; )
  ;; (dboard:areas-summary-control-panel-updater tabdat)
  ;; (let* ((last-runs-update  (dboard:tabdat-last-runs-update tabdat))
  ;; 	 (runs-dat     (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
  ;; 	 (runs-dat     (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
  ;; 	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
  ;;        (runs         (vector-ref runs-dat 1))
  ;; 	 (run-id       (dboard:tabdat-curr-run-id tabdat))
  ;;        (runs-hash (dashboard:areas-get-runs-hash tabdat))
  ;;        ;; (runs-hash    (let ((ht (make-hash-table)))
  ;; 	 ;;        	 (for-each (lambda (run)
  ;; 	 ;;        		     (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))




︙


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

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








+
-
+



-
-
+
+


-
+

-
+






-
+








	
	;; Bummer - we dont have the global get/set api mapped in chicken
	;; (let* ((modkeys (iup:global "MODKEYSTATE")))
	;;   (BB> "modkeys="modkeys))
	
	(debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status)
	;; status is corrupted on Brandon's home machine.  will have to wait until after shutdown to see if it is still broken in PDX SLES
	(let* ((dbstruct (dboard:get-dbstruct commondat #f))
	(let* ((toolpath (car (argv)))
	       (toolpath (car (argv)))
	       (key      (conc lin ":" col))
	       (test-id   (hash-table-ref/default cell-lookup key -1))
	       (run-id   (dboard:tabdat-curr-run-id tabdat))
	       (run-info (mrmt:get-run-info run-id))
	       (target   (mrmt:get-target run-id))
	       (run-info (db:get-run-info dbstruct run-id))
	       (target   (db:get-target dbstruct run-id))
	       (runname  (db:get-value-by-header (db:get-rows run-info)
						 (db:get-header run-info) "runname"))
	       (test-info  (mrmt:get-test-info-by-id run-id test-id))
	       (test-info  (db:get-test-info-by-id dbstruct run-id test-id))
	       (test-name (db:test-get-testname test-info))
	       (testpatt  (let ((tlast (mrmt:tasks-get-last target runname)))
	       (testpatt  (let ((tlast (db:tasks-get-last dbstruct target runname)))
			    (if tlast
				(let ((tpatt (tasks:task-get-testpatt tlast)))
				  (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
				      "%"
				      tpatt))
				"%")))
	       (item-path (db:test-get-item-path (mrmt:get-test-info-by-id run-id test-id)))
	       (item-path (db:test-get-item-path (db:get-test-info-by-id dbstruct run-id test-id)))
	       (item-test-path (conc test-name "/" (if (equal? item-path "")
						       "%" 
						       item-path)))
	       (status-chars (char-set->list (string->char-set status)))
	       (testpanel-cmd      (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &")))
	  (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]")
	  (cond




︙


253
254
255
256
257
258
259
260

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

276

277
278
279

280
281

282
283
284
285
286
287
288

254
255
256
257
258
259
260

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

276
277
278
279
280

281
282

283
284
285
286
287
288
289
290








-
+














-
+

+


-
+

-
+








					(debug:catch-and-dump
					 (lambda () ;; check that areas-matrix is initialized before calling the updater
					   (if areas-matrix 
					       (dashboard:areas-summary-updater commondat tabdat tb cell-lookup areas-matrix)))
					 "dashboard:areas-summary-updater")
					)
				   (mutex-unlock! update-mutex)))
         (runs-summary-control-panel (dashboard:areas-summary-control-panel tabdat)))
         (runs-summary-control-panel (dashboard:areas-summary-control-panel commondat tabdat)))
    (dboard:commondat-add-updater commondat areas-summary-updater tab-num: tab-num)
    (dboard:tabdat-runs-tree-set! tabdat tb)
    (iup:vbox
     (iup:split
      #:value 200
      tb
      areas-matrix)
     (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel))))

;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (dboard:areas-update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
(define (dboard:areas-update-rundat commondat tabdat runnamepatt numruns testnamepatt keypatts)
  (let* ((access-mode      (dboard:tabdat-access-mode tabdat))
	 (dbstruct         (dboard:get-dbstruct commondat #f))
         (keys             (dboard:tabdat-keys tabdat))
	 (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
         (allruns          (mrmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
         (allruns          (db:get-runs dbstruct runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
         ;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
         (allruns-tree    (mrmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname")
         (allruns-tree    (db:get-runs-by-patt dbstruct keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname")
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns)) ;; RA => Filtered as per runpatt selected
         (runs-tree   (db:get-rows   allruns-tree)) ;; RA => Returns complete list of runs
	 (start-time  (current-seconds))
	 (runs-hash   (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run header "id") run))




︙


303
304
305
306
307
308
309
310

311
312
313
314
315
316
317

305
306
307
308
309
310
311

312
313
314
315
316
317
318
319








-
+








	(let loop ((run      (car runs))
		   (tal      (cdr runs))
		   (res     '())
		   (maxtests 0))
	  (let* ((run-id       (db:get-value-by-header run header "id"))
		 (run-struct   (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
		 ;; (last-update  (if run-struct (dboard:rundat-last-update run-struct) 0))
		 (key-vals     (mrmt:get-key-vals run-id))
		 (key-vals     (db:get-key-vals dbstruct run-id))
		 (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
		 ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
		 ;;  dboard:get-tests-for-run-duplicate - returns a hash table
		 ;;  (dboard:get-tests-dat tabdat run-id last-update))
		 (all-test-ids (hash-table-keys tests-ht))
		 (num-tests    (length all-test-ids)))
	    ;; (print "run-struct: " run-struct)




︙


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

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








-
+

+


















-
+

+

-
+








		      (loop run tal new-res newmaxtests) ;; not done getting data for this run
		      (loop (car tal)(cdr tal) new-res newmaxtests)))))))
    (dboard:tabdat-filters-changed-set! tabdat #f)
    (dboard:areas-update-tree tabdat runs-hash header tb)))

;; runs update-rundat using the various filters from the gui
;;
(define (dashboard:areas-do-update-rundat tabdat)
(define (dashboard:areas-do-update-rundat commondat tabdat)
  (dboard:areas-update-rundat
   commondat 
   tabdat
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
   (dboard:tabdat-numruns tabdat)
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
   ;; generate key patterns from the target stored in tabdat
   (let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
     (let ((fres   (if (dboard:tabdat-target tabdat)
                       (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%"))))
                         (map (lambda (k v)(list k v)) dbkeys ptparts))
                       (let ((res '()))
                         (for-each (lambda (key)
                                     (if (not (equal? key "runname"))
                                         (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
                                           (if val (set! res (cons (list key val) res))))))
                                   dbkeys)
                         res))))
       fres))))

(define (dashboard:areas-get-runs-hash tabdat)
(define (dashboard:areas-get-runs-hash commondat tabdat)
  (let* ((access-mode       (dboard:tabdat-access-mode tabdat))
	 (dbstruct          (dboard:get-dbstruct commondat #f))
         (last-runs-update  0);;(dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-dat     (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
         (runs         (vector-ref runs-dat 1))
	 (run-id       (dboard:tabdat-curr-run-id tabdat))
         (runs-hash    (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
				   runs) ht)))




︙


412
413
414
415
416
417
418
419

420
421
422
423
424
425
426

416
417
418
419
420
421
422

423
424
425
426
427
428
429
430








-
+








;; open the area dbs, given list of areas that are "cared about"
;;    areas: '( (area_name . path) ... ) ;; NOT necessarily the section [areas] from megatest.config
;;
(define (dboard:areas-open-areas commondat tabdat areas)
  (let ((areas-ht (dboard:commondat-areas commondat)))
    (for-each
     (lambda (area-dat)
       (db:dashboard-open-db areas (car area-dat)(cdr area-dat)))
       (db:dashboard-open-dbstruct areas (car area-dat)(cdr area-dat)))
     areas)))



(define (dboard:areas-update-tree tabdat runs-hash runs-header tb)
  (let* ((tree-path     (dboard:tabdat-tree-path tabdat))
	;; (access-mode   (dboard:tabdat-access-mode tabdat))




︙


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

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








-
+

-
+













-
-
+
+
+



-
-
+
+








    ;;	       ;;                                             userdata: (conc "run-id: " run-id))))
    ;;	       (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
    ;;	       ;; (set! colnum (+ colnum 1))
    ;;	       ))))
    ;; (append new-run-ids run-ids)))) ;; for-each run-id
    ))
    
(define (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash)
(define (dashboard:areas-run-id->tests-mindat dbstruct run-id tabdat runs-hash)
  (let* ((run          (hash-table-ref/default runs-hash run-id #f))
         (key-vals     (mrmt:get-key-vals run-id))
         (key-vals     (db:get-key-vals dbstruct run-id))
         (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
         (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
         (tests-dat    (dashboard:tests-ht->tests-dat tests-ht)) 
         (tests-mindat (dcommon:minimize-test-data tests-dat)))  ;; reduces data for display
    (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
    (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat)
    (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10))
    (when (not run)
        (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id)
        (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash))
        )
    tests-mindat))

(define (dashboard:areas-runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f))
  (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat))
(define (dashboard:areas-runs-summary-xor-matrix-content commondat tabdat runs-hash #!key (hide-clean #f))
  (let* ((dbstruct    (dboard:get-dbstruct commondat #f))
	 (src-run-id  (dboard:tabdat-prev-run-id tabdat))
         (dest-run-id (dboard:tabdat-curr-run-id tabdat)))
    (if (and src-run-id dest-run-id)
        (dcommon:xor-tests-mindat 
         (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash)
         (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash)
         (dashboard:run-id->tests-mindat dbstruct src-run-id tabdat runs-hash)
         (dashboard:run-id->tests-mindat dbstruct dest-run-id tabdat runs-hash)
         hide-clean: hide-clean)
        #f)))

(define (dashboard:areas-popup-menu  run-id test-id target runname test-name testpatt item-test-path test-info)
  (iup:menu 
   (iup:menu-item
    "Test Control Panel"




︙


557
558
559
560
561
562
563
564
565
566
567
568
569
570
571

562
563
564
565
566
567
568

569
570
571
572
573
574
575








-








    (lambda (obj)
      (dcommon:examine-xterm run-id test-id)))

   (iup:menu-item
    (conc "Kill " item-test-path)
    #:action
    (lambda (obj)
      ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
      (common:run-a-command
       (conc "megatest -set-state-status KILLREQ,n/a -target " target
             " -runname " runname
             " -testpatt " item-test-path 
             " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))

   




︙


630
631
632
633
634
635
636
637
638
639
640
641
642
643
644

634
635
636
637
638
639
640

641
642
643
644
645
646
647








-








               " -runname " runname
	       " -testpatt " item-test-path
	       " -preclean -clean-cache"))))
     (iup:menu-item
      (conc "Kill " item-test-path)
      #:action
      (lambda (obj)
        ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
	(common:run-a-command
	 (conc "megatest -set-state-status KILLREQ,n/a -target " target
               " -runname " runname
	       " -testpatt " item-test-path 
	       " -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))
     (iup:menu-item
      (conc "Delete data : " item-test-path)




︙


697
698
699
700
701
702
703
704

705
706
707
708
709
710
711
712
713
714
715
716

717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735

736
737
738
739
740


741
742
743

744
745
746



747
748
749
750
751
752
753

754
755
756

757
758
759
760
761
762
763

700
701
702
703
704
705
706

707
708
709
710
711
712
713
714
715
716
717
718

719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737

738
739
740
741


742
743
744
745

746
747


748
749
750
751
752
753
754
755
756

757
758
759

760
761
762
763
764
765
766
767








-
+











-
+


















-
+



-
-
+
+


-
+

-
-
+
+
+






-
+


-
+








  (or please-update-buttons
      (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific
	   (> modtime (- last-db-update-time 3)) ;; add three seconds of margin
	   (> (current-seconds)(+ last-db-update-time 1)))))

;; setup buttons and callbacks to switch between modes in runs summary tab
;;
(define (dashboard:areas-summary-control-panel tabdat)
(define (dashboard:areas-summary-control-panel commondat tabdat)
  (let* ((summary-buttons ;; build buttons
          (map
           (lambda (mode-item)
             (let* ((this-mode (car mode-item))
                    (this-mode-label (cdr mode-item)))
               (iup:button this-mode-label
                           #:action
                           (lambda (obj)
                             (debug:catch-and-dump
                              (lambda ()
                                (dboard:tabdat-runs-summary-mode-set! tabdat this-mode)
                                (dboard:areas-summary-control-panel-updater tabdat))
                                (dboard:areas-summary-control-panel-updater commondat tabdat))
                              "runs summary control panel updater")))))
           (dboard:tabdat-runs-summary-modes tabdat)))
         (summary-buttons-hbox (apply iup:hbox summary-buttons))
         (xor-runname-labels-hbox
          (iup:hbox
           (let ((temp-label
                  (iup:label "" #:size "125x15" #:fontsize "10" )))
             (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label)
             temp-label
             )
           (let ((temp-label
                  (iup:label "" #:size "125x15" #:fontsize "10")))
             (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label)
             temp-label))))
    (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons)

    ;; maybe wrap in a frame
    (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox )))
      (dboard:areas-summary-control-panel-updater tabdat)
      (dboard:areas-summary-control-panel-updater commondat tabdat)
      res
      )))

(define (dboard:areas-summary-control-panel-updater tabdat)
  (dboard:areas-summary-xor-labels-updater tabdat)
(define (dboard:areas-summary-control-panel-updater commondat tabdat)
  (dboard:areas-summary-xor-labels-updater commondat tabdat)
  (dboard:areas-summary-buttons-updater tabdat))

(define (dboard:areas-summary-xor-labels-updater tabdat)
(define (dboard:areas-summary-xor-labels-updater commondat tabdat)
  (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat))
        (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat))
        (mode (dboard:tabdat-runs-summary-mode tabdat)))
        (dest-runname-label   (dboard:tabdat-runs-summary-dest-runname-label tabdat))
        (mode                 (dboard:tabdat-runs-summary-mode tabdat))
	(dbstruct             (dboard:get-dbstruct commondat #f)))
    (when (and source-runname-label dest-runname-label)
      (case mode
        ((xor-two-runs xor-two-runs-hide-clean)
         (let* ((curr-run-id          (dboard:tabdat-curr-run-id tabdat))
                (prev-run-id          (dboard:tabdat-prev-run-id tabdat))
                (curr-runname (if curr-run-id
                                  (mrmt:get-run-name-from-id curr-run-id)
                                  (db:get-run-name-from-id dbstruct curr-run-id)
                                  "None"))
                (prev-runname (if prev-run-id
                                  (mrmt:get-run-name-from-id prev-run-id)
                                  (db:get-run-name-from-id dbstruct prev-run-id)
                                  "None")))
           (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname"  "))
           (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname"  "))))
        (else
         (iup:attribute-set! source-runname-label "TITLE" "")
         (iup:attribute-set! dest-runname-label "TITLE" ""))))))





︙







Modified dashboard.scm
from [f1ca685f34]
to [e2c358fe88].




︙


46
47
48
49
50
51
52
53

54
55
56
57
58
59
60
61
62
63
64
65
66

46
47
48
49
50
51
52

53
54
55
56
57
58

59
60
61
62
63
64
65








-
+





-








(include "task_records.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")

(define help (conc 
	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2012-2016
  license GPL, Copyright (C) Matt Welland 2012-2017

Usage: dashboard [options]
  -h                    : this help
  -test run-id,test-id  : control test identified by testid
  -skip-version-check   : skip the version check
  -use-db-cache         : access database via cache 

Misc
  -rows R         : set number of rows
  -cols C         : set number of columns
"))

;;   -server host:port     : connect to host:port instead of db access




︙


81
82
83
84
85
86
87
88

89
90
91
92
93
94
95

80
81
82
83
84
85
86

87
88
89
90
91
92
93
94








-
+








			) 
		 (list  "-h"
			"-use-server"
			"-guimonitor"
			"-main"
			"-v"
			"-q"
			"-use-db-cache"
			;; "-use-db-cache"
			"-skip-version-check"
			"-repl"
                        "-rh5.11" ;; fix to allow running on rh5.11
			)
		 args:arg-hash
		 0))





︙


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

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








-
+



+
+
+
+
+
+
+
+
+
+










-
+








  please-update  
  (tabdats            (make-hash-table))
  (update-mutex       (make-mutex))
  (updaters           (make-hash-table))
  (updating           #f)
  uidat                                   ;; needs to move to tabdat at some time
  (hide-not-hide-tabs #f)
  (current-area-path  #f)                 ;; the area of the path where the dashboard was started, if it is a megatest area
  (default-area-path  #f)                 ;; the area of the path where the dashboard was started, if it is a megatest area
  (areas              (make-hash-table))  ;; area-name ==> dbstruct
  ;; (area-dbs           #f)                 ;; use db:dashboard-open-db to add areas to the areas hash  
  )

;; general "db getter"
;;
(define (dboard:get-dbstruct commondat area-path-in) ;; area-path=#f gets local connection
  (let ((areas (dboard:commondat-areas commondat))
	(apath (or area-path-in (current-directory))))
    (or (db:dashboard-open-dbstruct areas "local" apath)
	(begin
	  (debug:print 0 *default-debug-port* "Failed to open db in directory " apath ", are you staring dashboard in a Megatest area? Exiting...")
	  (exit 1)))))

;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary)
;;
(define (dboard:common-get-tabdat commondat #!key (tab-num #f))
  (let* ((tnum (or tab-num
		   (dboard:commondat-curr-tab-num commondat)
		   0)) ;; tab-num value is curr-tab-num value in passed commondat
	 (ht   (dboard:commondat-tabdats commondat))
	 (res  (hash-table-ref/default ht tnum #f)))
    (or res
	(let ((new-tabdat  (dboard:tabdat-make-data)))
	(let ((new-tabdat  (dboard:tabdat-make-data commondat)))
	  (hash-table-set! ht tnum new-tabdat)
	  new-tabdat))))

;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table
;;
(define (dboard:common-set-tabdat! commondat tabnum tabdat)
  (hash-table-set!




︙


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

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








-
+

-
+



-
+




+
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+








(define (dboard:tabdat-test-patts-use vec)    
  (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for?

;; additional setters for dboard:data
(define (dboard:tabdat-test-patts-set!-use    vec val)
  (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))

(define (dboard:tabdat-make-data)
(define (dboard:tabdat-make-data commondat)
  (let ((dat (make-dboard:tabdat)))
    (dboard:setup-tabdat dat)
    (dboard:setup-tabdat commondat dat)
    (dboard:setup-num-rows dat)
    dat))

(define (dboard:setup-tabdat tabdat)
(define (dboard:setup-tabdat commondat tabdat)
  ;; (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
  ;; (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path))
  ;; (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))

  (let ((dbstruct (dboard:get-dbstruct commondat #f)))
  ;; HACK ALERT: this is a hack, please fix.
  (if #f
      (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
      (print "FIXME on line 350"))
  
  (dboard:tabdat-keys-set! tabdat (mrmt:get-keys))
  (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
  (dboard:tabdat-tot-runs-set! tabdat (mrmt:get-num-runs "%"))
  )
    ;; HACK ALERT: this is a hack, please fix.
    (if #f
	(dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
	(print "FIXME on line 350"))
    
    (dboard:tabdat-keys-set! tabdat (db:get-keys dbstruct))
    (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
    (dboard:tabdat-tot-runs-set! tabdat (db:get-num-runs dbstruct "%"))
    ))

;; RADT => Matrix defstruct addition
(defstruct dboard:graph-dat
    ((id           #f) : string)
    ((color        #f) : vector)
    ((flag         #t) : boolean)
    ((cell         #f) : number)




︙


377
378
379
380
381
382
383
384

385
386
387
388
389
390
391

387
388
389
390
391
392
393

394
395
396
397
398
399
400
401








-
+









(define (dboard:runsdat-make-init)
  (make-dboard:runsdat
   runs-index: (make-hash-table)
   tests-index: (make-hash-table)
   matrix-dat: (make-sparse-array)))

;; used to keep the rundata from mrmt:get-tests-for-run
;; used to keep the rundata from db:get-tests-for-run
;; in sync. 
;;
(defstruct dboard:rundat
  run
  tests-drawn    ;; list of id's already drawn on screen
  tests-notdrawn ;; list of id's NOT already drawn
  rowsused       ;; hash of lists covering what areas used - replace with quadtree




︙


537
538
539
540
541
542
543
544
545



546
547
548
549
550
551
552

547
548
549
550
551
552
553


554
555
556
557
558
559
560
561
562
563








-
-
+
+
+









;; This is roughly the same as dboard:get-tests-dat, should merge them if possible
;;
;; gets all the tests for run-id that match testnamepatt and key-vals, merges them
;;
;;    NOTE: Yes, this is used
;;
(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)
  (let* ((start-time   (current-seconds))
(define (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals)
  (let* ((dbstruct     (dboard:get-dbstruct commondat #f))
	 (start-time   (current-seconds))
	 (access-mode  (dboard:tabdat-access-mode tabdat))
         (num-to-get   (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get")
                                           "200")))
	 (states       (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))
	 (statuses     (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
         (do-not-use-db-file-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab
         (do-not-use-query-timestamps   #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab




︙


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

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








-
+









-
+








                        ;;(dboard:tabdat-filters-changed tabdat))
                        0
                        (dboard:rundat-last-update run-dat)))
	 (last-db-time (if do-not-use-db-file-timestamps
			   0
			   (dboard:rundat-last-db-time run-dat)))
	 (db-path      (or (dboard:rundat-db-path run-dat)
			   (let* ((db-dir (common:get-db-tmp-area))
			   (let* ((db-dir (common:get-db-tmp-area dbstruct))
				  (db-pth (conc db-dir "/megatest.db")))
			     (dboard:rundat-db-path-set! run-dat db-pth)
			     db-pth)))
	 (db-mod-time  (common:lazy-sqlite-db-modification-time db-path))
	 (db-modified  (>= db-mod-time last-db-time))
	 (multi-get    (> (dboard:rundat-run-data-offset run-dat) 0))  ;; multi-get in progress
	 (tmptests     (if (or do-not-use-db-file-timestamps
			       (dboard:tabdat-filters-changed tabdat)
			       db-modified)
			   (mrmt:get-tests-for-run run-id testnamepatt states statuses     ;; run-id testpatt states statuses
			   (db:get-tests-for-run dbstruct run-id testnamepatt states statuses     ;; run-id testpatt states statuses
					      (dboard:rundat-run-data-offset run-dat) ;; query offset
					      num-to-get
					      (dboard:tabdat-hide-not-hide tabdat) ;; no-in
					      sort-by                              ;; sort-by
					      sort-order                           ;; sort-order
					      #f ;; 'shortlist                     ;; qrytype
					      last-update                          ;; last-update




︙


649
650
651
652
653
654
655
656
657
658




659
660

661
662

663
664
665
666
667
668
669

660
661
662
663
664
665
666



667
668
669
670
671

672


673
674
675
676
677
678
679
680








-
-
-
+
+
+
+

-
+
-
-
+








;; 	newdat)))

;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
  (let* ((access-mode      (dboard:tabdat-access-mode tabdat))
         (keys             (mrmt:get-keys))
(define (update-rundat commondat tabdat runnamepatt numruns testnamepatt keypatts)
  (let* ((dbstruct         (dboard:get-dbstruct commondat #f)) ;; get access to local area
	 (access-mode      (dboard:tabdat-access-mode tabdat))
         (keys             (db:get-keys dbstruct))
	 (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
         (allruns          (mrmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
         (allruns          (db:get-runs dbstruct runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
         ;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
         (allruns-tree    (mrmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname")
         (allruns-tree    (db:get-runs-by-patt dbstruct keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname")
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns)) ;; RA => Filtered as per runpatt selected
         (runs-tree   (db:get-rows   allruns-tree)) ;; RA => Returns complete list of runs
	 (start-time  (current-seconds))
	 (runs-hash   (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run header "id") run))




︙


686
687
688
689
690
691
692
693
694


695
696
697
698
699
700
701

697
698
699
700
701
702
703


704
705
706
707
708
709
710
711
712








-
-
+
+








	(let loop ((run      (car runs))
		   (tal      (cdr runs))
		   (res     '())
		   (maxtests 0))
	  (let* ((run-id       (db:get-value-by-header run header "id"))
		 (run-struct   (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
		 (last-update  (if run-struct (dboard:rundat-last-update run-struct) 0))
		 (key-vals     (mrmt:get-key-vals run-id))
		 (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
		 (key-vals     (db:get-key-vals dbstruct run-id))
		 (tests-ht     (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals))
		 ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
		 ;;  dboard:get-tests-for-run-duplicate - returns a hash table
		 ;;  (dboard:get-tests-dat tabdat run-id last-update))
		 (all-test-ids (hash-table-keys tests-ht))
		 (num-tests    (length all-test-ids)))
	    ;; (print "run-struct: " run-struct)
	    ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)




︙


728
729
730
731
732
733
734
735
736
737




738
739
740
741



742
743
744
745
746
747
748

739
740
741
742
743
744
745



746
747
748
749
750



751
752
753
754
755
756
757
758
759
760








-
-
-
+
+
+
+

-
-
-
+
+
+








    (dboard:update-tree tabdat runs-hash header tb)))

;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
  (let* ((access-mode      (dboard:tabdat-access-mode tabdat))
         (keys             (dboard:tabdat-keys tabdat)) ;; (db:dispatch-query access-mode mrmt:get-keys db:get-keys)))
(define (dboard:update-rundat commondat tabdat runnamepatt numruns testnamepatt keypatts)
  (let* ((dbstruct         (dboard:get-dbstruct commondat #f))
	 (access-mode      (dboard:tabdat-access-mode tabdat))
         (keys             (dboard:tabdat-keys tabdat)) 
	 (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
         (allruns          (mrmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
         ;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
         (allruns-tree    (mrmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname")
         (allruns          (db:get-runs dbstruct runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
         ;;(allruns-tree (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
         (allruns-tree    (db:get-runs-by-patt dbstruct keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname")
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns)) ;; RA => Filtered as per runpatt selected
         (runs-tree   (db:get-rows   allruns-tree)) ;; RA => Returns complete list of runs
	 (start-time  (current-seconds))
	 (runs-hash   (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run header "id") run))




︙


763
764
765
766
767
768
769
770
771


772
773
774
775
776
777
778

775
776
777
778
779
780
781


782
783
784
785
786
787
788
789
790








-
-
+
+








	(let loop ((run      (car runs))
		   (tal      (cdr runs))
		   (res     '())
		   (maxtests 0))
	  (let* ((run-id       (db:get-value-by-header run header "id"))
		 (run-struct   (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
		 ;; (last-update  (if run-struct (dboard:rundat-last-update run-struct) 0))
		 (key-vals     (mrmt:get-key-vals run-id))
		 (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
		 (key-vals     (db:get-key-vals dbstruct run-id))
		 (tests-ht     (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals))
		 ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
		 ;;  dboard:get-tests-for-run-duplicate - returns a hash table
		 ;;  (dboard:get-tests-dat tabdat run-id last-update))
		 (all-test-ids (hash-table-keys tests-ht))
		 (num-tests    (length all-test-ids)))
	    ;; (print "run-struct: " run-struct)
	    ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)




︙


1152
1153
1154
1155
1156
1157
1158
1159
1160



1161
1162

1163
1164
1165
1166
1167
1168
1169

1164
1165
1166
1167
1168
1169
1170


1171
1172
1173
1174

1175
1176
1177
1178
1179
1180
1181
1182








-
-
+
+
+

-
+








      (if val
	  val
	  (if (not (null? values))
	      (let ((newval (car values)))
		(iup:attribute-set! lb "VALUE" newval)
		newval))))))

(define (dashboard:update-target-selector tabdat #!key (action-proc #f))
  (let* ((runconf-targs (common:get-runconfig-targets))
(define (dashboard:update-target-selector commondat tabdat #!key (action-proc #f))
  (let* ((dbstruct      (dboard:get-dbstruct commondat #f))
	 (runconf-targs (common:get-runconfig-targets))
	 (key-lbs       (dboard:tabdat-key-listboxes tabdat))
	 (db-target-dat (mrmt:get-targets))
	 (db-target-dat (db:get-targets dbstruct))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (munge-target  (lambda (x)            ;; create a target vector from a string. Pad with na if needed.
			  (list->vector
			   (take (append (string-split x "/")
					 (make-list (length header) "na"))
				 (length header)))))




︙


1310
1311
1312
1313
1314
1315
1316
1317

1318
1319
1320

1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333



1334
1335

1336
1337
1338
1339
1340
1341
1342

1323
1324
1325
1326
1327
1328
1329

1330
1331
1332

1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344


1345
1346
1347
1348

1349
1350
1351
1352
1353
1354
1355
1356








-
+


-
+











-
-
+
+
+

-
+








;;======================================================================
;; R U N   C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;

(define (dboard:target-updater tabdat) ;;  key-listboxes)
(define (dboard:target-updater commondat tabdat) ;;  key-listboxes)
  (let ((targ (map (lambda (x)
		     (iup:attribute x "VALUE"))
		   (car (dashboard:update-target-selector tabdat))))
		   (car (dashboard:update-target-selector commondat tabdat))))
	(curr-runname (dboard:tabdat-run-name tabdat)))
    (dboard:tabdat-target-set! tabdat targ)
    ;; (if (dboard:tabdat-updater-for-runs tabdat)
    ;; 	 ((dboard:tabdat-updater-for-runs tabdat)))
    (if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat)))
	    (equal? (dboard:tabdat-run-name tabdat) ""))
	(dboard:tabdat-run-name-set! tabdat curr-runname))
    (dashboard:update-run-command tabdat)))

;; used by run-controls
;;
(define (dashboard:update-tree-selector tabdat #!key (action-proc #f))
  (let* ((tb            (dboard:tabdat-runs-tree tabdat))
(define (dashboard:update-tree-selector commondat tabdat #!key (action-proc #f))
  (let* ((dbstruct      (dboard:get-dbstruct commondat #f))
	 (tb            (dboard:tabdat-runs-tree tabdat))
	 (runconf-targs (common:get-runconfig-targets))
	 (db-target-dat (mrmt:get-targets))
	 (db-target-dat (db:get-targets dbstruct))
         (runs-tree-ht  (dboard:tabdat-runs-tree-ht tabdat))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (munge-target  (lambda (x)            ;; create a target vector from a string. Pad with na if needed.
			  (take (append (string-split x "/")
					(make-list (length header) "na"))
				(length header))))




︙


1366
1367
1368
1369
1370
1371
1372
1373

1374
1375
1376
1377
1378
1379
1380

1380
1381
1382
1383
1384
1385
1386

1387
1388
1389
1390
1391
1392
1393
1394








-
+








	 (test-names    (hash-table-keys all-tests-registry))
	 (sorted-testnames #f)
	 (action        "-run")
	 (cmdln         "")
	 (runlogs       (make-hash-table))
	 ;;; (key-listboxes #f)
	 (update-keyvals (lambda () ;; gets called in dashboard:update-target-selector as "action-proc"
			   (dboard:target-updater (dboard:tabdat-key-listboxes tabdat))))
			   (dboard:target-updater commondat (dboard:tabdat-key-listboxes tabdat))))
	 (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas
	 (test-patterns-textbox  #f))
    (hash-table-set! tests-draw-state 'first-time #t)
    ;; (hash-table-set! tests-draw-state 'scalef 1)
    (tests:get-full-data test-names test-records '() all-tests-registry)
    (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
    




︙


1400
1401
1402
1403
1404
1405
1406
1407

1408
1409
1410
1411
1412
1413
1414

1414
1415
1416
1417
1418
1419
1420

1421
1422
1423
1424
1425
1426
1427
1428








-
+








	     ;;  key-listboxes))
	     (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state))))
	   (tb (dboard:tabdat-runs-tree tabdat)))
      (dboard:commondat-add-updater 
       commondat 
       (lambda ()
         (if (dashboard:database-changed? commondat tabdat context-key: 'run-control)
             (dashboard:update-tree-selector tabdat)))
             (dashboard:update-tree-selector commondat tabdat)))
       tab-num: tab-num)
      result)))

 ;;(iup:frame
 ;; #:title "Logs" ;; To be replaced with tabs
 ;; (let ((logs-tb (iup:textbox #:expand "YES"
 ;;				   #:multiline "YES")))




︙


1499
1500
1501
1502
1503
1504
1505
1506

1507
1508
1509
1510
1511
1512
1513

1513
1514
1515
1516
1517
1518
1519

1520
1521
1522
1523
1524
1525
1526
1527








-
+








									 (dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
									 (dboard:tabdat-running-layout-set! tabdat #f))
								       "run-times-tab-layout-updater")))
						     ))))))
				   "dashboard:run-times-tab-updater")))
	 (key-listboxes #f) ;; 
	 (update-keyvals (lambda ()
			   (dboard:target-updater tabdat))))
			   (dboard:target-updater commondat tabdat))))
    (dboard:tabdat-drawing-set! tabdat drawing)
    (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num)
    (iup:split
     #:orientation "VERTICAL" ;; "HORIZONTAL"
     #:value 150
     (iup:vbox





︙


1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685

1686
1687
1688
1689
1690
1691
1692

1648
1649
1650
1651
1652
1653
1654


























1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672

1673
1674
1675
1676
1677
1678
1679
1680








-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-


















-
+








;; display and manage a single run at a time

(define (tree-path->run-id tabdat path)
  (if (not (null? path))
      (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
      #f))

;; (define (dboard:get-tests-dat tabdat run-id last-update)
;;   (let* ((access-mode     (dboard:tabdat-access-mode tabdat))
;;          (tdat (if run-id (db:dispatch-query access-mode mrmt:get-tests-for-run db:get-tests-for-run
;;                                              run-id 
;; 					     (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
;; 					     (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))  ;; '()
;; 					     (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '()
;; 					     #f #f                                                       ;; offset limit
;; 					     (dboard:tabdat-hide-not-hide tabdat)                        ;; not-in
;; 					     #f #f                                                       ;; sort-by sort-order
;; 					     #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration"                        ;; qryval
;;                                              (if (dboard:tabdat-filters-changed tabdat)
;; 					         0
;; 					         last-update)
;; 					     *dashboard-mode*)
;; 		  '()))) ;; get 'em all
;;     ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id)
;;     (sort tdat (lambda (a b)
;; 		 (let* ((aval (vector-ref a 2))
;; 			(bval (vector-ref b 2))
;; 			(anum (string->number aval))
;; 			(bnum (string->number bval)))
;; 		   (if (and anum bnum)
;; 		       (< anum bnum)
;; 		       (string<= aval bval)))))))


(define (dashboard:safe-cadr-assoc name lst)
  (let ((res (assoc name lst)))
    (if (and res (> (length res) 1))
	(cadr res)
	#f)))

(define (dboard:update-tree tabdat runs-hash runs-header tb)
  (let* ((access-mode   (dboard:tabdat-access-mode tabdat))
         (run-ids (sort (filter number? (hash-table-keys runs-hash))
			(lambda (a b)
			  (let* ((record-a (hash-table-ref runs-hash a))
				 (record-b (hash-table-ref runs-hash b))
				 (time-a   (db:get-value-by-header record-a runs-header "event_time"))
				 (time-b   (db:get-value-by-header record-b runs-header "event_time")))
			    (< time-a time-b)))))
         (changed      #f)
	 (last-runs-update  (dboard:tabdat-last-runs-update tabdat)))
	 ;; (runs-dat     (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)))
	 ;; (runs-dat     (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)))
    (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
    (for-each (lambda (run-id)
		(let* ((run-record (hash-table-ref/default runs-hash run-id #f))
		       (key-vals   (map (lambda (key)(db:get-value-by-header run-record runs-header key))
					(dboard:tabdat-keys tabdat)))
		       (run-name   (db:get-value-by-header run-record runs-header "runname"))
		       (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name))




︙


1719
1720
1721
1722
1723
1724
1725
1726

1727

1728

1729
1730

1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743



1744
1745
1746
1747
1748


1749
1750
1751
1752
1753

1754

1755
1756

1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776









1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791




1792
1793
1794
1795
1796
1797
1798
1799
1800
1801

1802
1803
1804
1805
1806
1807
1808
1809

1707
1708
1709
1710
1711
1712
1713

1714
1715
1716

1717
1718

1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730


1731
1732
1733
1734
1735
1736


1737
1738
1739
1740
1741
1742

1743
1744
1745
1746

1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759








1760
1761
1762
1763
1764
1765
1766
1767
1768






1769
1770
1771
1772
1773




1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786

1787

1788
1789
1790
1791
1792
1793
1794








-
+

+
-
+

-
+











-
-
+
+
+



-
-
+
+




-
+

+

-
+












-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-





-
-
-
-
+
+
+
+









-
+
-








        (cond
         ((< 0 (string-compare3 a-test-name b-test-name)) #t)
         ((> 0 (string-compare3 a-test-name b-test-name)) #f)
         ((< 0 (string-compare3 a-item-path b-item-path)) #t)
         (else #f)))))))


(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash)
(define (dashboard:run-id->tests-mindat commondat run-id tabdat runs-hash)
  (let* ((run          (hash-table-ref/default runs-hash run-id #f))
	 (dbstruct     (dboard:get-dbstruct commondat #f))
         (key-vals     (mrmt:get-key-vals run-id))
         (key-vals     (db:get-key-vals dbstruct run-id))
         (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
         (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
         (tests-ht     (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals))
         (tests-dat    (dashboard:tests-ht->tests-dat tests-ht)) 
         (tests-mindat (dcommon:minimize-test-data tests-dat)))  ;; reduces data for display
    (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
    (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat)
    (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10))
    (when (not run)
        (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id)
        (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash))
        )
    tests-mindat))

(define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f))
  (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat))
(define (dashboard:runs-summary-xor-matrix-content commondat tabdat runs-hash #!key (hide-clean #f))
  (let* (;; (dbstruct   (dboard:get-dbstruct commondat #f))
	 (src-run-id (dboard:tabdat-prev-run-id tabdat))
         (dest-run-id (dboard:tabdat-curr-run-id tabdat)))
    (if (and src-run-id dest-run-id)
        (dcommon:xor-tests-mindat 
         (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash)
         (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash)
         (dashboard:run-id->tests-mindat commondat src-run-id tabdat runs-hash)
         (dashboard:run-id->tests-mindat commondat dest-run-id tabdat runs-hash)
         hide-clean: hide-clean)
        #f)))


(define (dashboard:get-runs-hash tabdat)
(define (dashboard:get-runs-hash commondat tabdat)
  (let* ((access-mode       (dboard:tabdat-access-mode tabdat))
	 (dbstruct          (dboard:get-dbstruct commondat #f))
         (last-runs-update  0);;(dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-dat     (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
         (runs         (vector-ref runs-dat 1))
	 (run-id       (dboard:tabdat-curr-run-id tabdat))
         (runs-hash    (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
				   runs) ht)))
    runs-hash))
         

(define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)
  ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat)
  (dashboard:do-update-rundat tabdat) ;; )
  (dboard:runs-summary-control-panel-updater tabdat)
  (let* ((last-runs-update  (dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
         (runs         (vector-ref runs-dat 1))
	 (run-id       (dboard:tabdat-curr-run-id tabdat))
         (runs-hash (dashboard:get-runs-hash tabdat))
  (dashboard:do-update-rundat commondat tabdat) ;; )
  (dboard:runs-summary-control-panel-updater commondat tabdat)
  (let* ((dbstruct          (dboard:get-dbstruct commondat #f))
	 (last-runs-update  (dboard:tabdat-last-runs-update tabdat))
	 (runs-dat          (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header       (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
         (runs              (vector-ref runs-dat 1))
	 (run-id            (dboard:tabdat-curr-run-id tabdat))
         (runs-hash         (dashboard:get-runs-hash commondat tabdat)))
         ;; (runs-hash    (let ((ht (make-hash-table)))
	 ;;        	 (for-each (lambda (run)
	 ;;        		     (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
	 ;;        		   runs)
	 ;;        	 ht))
         )
    (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-tree)
        (dboard:update-tree tabdat runs-hash runs-header tb))
    (if run-id
        (let* ((matrix-content
                (case (dboard:tabdat-runs-summary-mode tabdat) 
                  ((one-run) (dashboard:run-id->tests-mindat run-id tabdat runs-hash))
                  ((xor-two-runs) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash))
                  ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t))
                  (else (dashboard:run-id->tests-mindat run-id tabdat runs-hash)))))
                  ((one-run)                 (dashboard:run-id->tests-mindat commondat run-id tabdat runs-hash))
                  ((xor-two-runs)            (dashboard:runs-summary-xor-matrix-content commondat tabdat runs-hash))
                  ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content commondat tabdat runs-hash hide-clean: #t))
                  (else (dashboard:run-id->tests-mindat commondat run-id tabdat runs-hash)))))
          (when matrix-content
            (let* ((indices      (common:sparse-list-generate-index matrix-content)) ;;  proc: set-cell))
                   (row-indices  (cadr indices))
                   (col-indices  (car indices))
                   (max-row      (if (null? row-indices) 1 (common:max (map cadr row-indices))))
                   (max-col      (if (null? col-indices) 1 (common:max (map cadr col-indices))))
                   (max-visible  (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window
                   (numrows      1)
                   (numcols      1)
                   (changed      #f)
                   (changed      #f))
                   )
              
              (dboard:tabdat-filters-changed-set! tabdat #f)
              (let loop ((pass-num 0)
                         (changed  #f))
                ;; Update the runs tree
                ;; (dboard:update-tree tabdat runs-hash runs-header tb)
                




︙


1881
1882
1883
1884
1885
1886
1887



1888

1889
1890
1891
1892
1893
1894
1895

1866
1867
1868
1869
1870
1871
1872
1873
1874
1875

1876
1877
1878
1879
1880
1881
1882
1883








+
+
+
-
+









;;======================================================================
;; S U M M A R Y 
;;======================================================================
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary commondat tabdat #!key (tab-num #f))
  (let* ((dbstruct         (dboard:get-dbstruct commondat #f))
	 (configdat        (dbr:dbstruct-configdat dbstruct))
	 (rawconfig        configdat)
  (let* ((rawconfig        (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
	 ;; (rawconfig        (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
	 (changed          #f))
    (iup:vbox
     (iup:split
      #:value 300
      (iup:frame 
       #:title "General Info"
       (iup:vbox




︙


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

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








-
+

-
-
+
+
+






-
+


-
+







-
-
+
+





-
+











-
+


















-
+












+
-
+








               (nonsel-color "170 170 170")
               (current-mode (dboard:tabdat-runs-summary-mode tabdat)))
          (if (eq? this-mode current-mode)
              (iup:attribute-set! this-button "BGCOLOR" sel-color)
              (iup:attribute-set! this-button "BGCOLOR" nonsel-color))
          (loop (cdr buttons-left) (cdr modes-left))))))

(define (dboard:runs-summary-xor-labels-updater tabdat)
(define (dboard:runs-summary-xor-labels-updater commondat tabdat)
  (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat))
        (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat))
        (mode (dboard:tabdat-runs-summary-mode tabdat)))
        (dest-runname-label   (dboard:tabdat-runs-summary-dest-runname-label tabdat))
        (mode                 (dboard:tabdat-runs-summary-mode tabdat))
	(dbstruct             (dboard:get-dbstruct commondat #f)))
    (when (and source-runname-label dest-runname-label)
      (case mode
        ((xor-two-runs xor-two-runs-hide-clean)
         (let* ((curr-run-id          (dboard:tabdat-curr-run-id tabdat))
                (prev-run-id          (dboard:tabdat-prev-run-id tabdat))
                (curr-runname (if curr-run-id
                                  (mrmt:get-run-name-from-id curr-run-id)
                                  (db:get-run-name-from-id dbstruct curr-run-id)
                                  "None"))
                (prev-runname (if prev-run-id
                                  (mrmt:get-run-name-from-id prev-run-id)
                                  (db:get-run-name-from-id dbstruct prev-run-id)
                                  "None")))
           (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname"  "))
           (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname"  "))))
        (else
         (iup:attribute-set! source-runname-label "TITLE" "")
         (iup:attribute-set! dest-runname-label "TITLE" ""))))))

(define (dboard:runs-summary-control-panel-updater tabdat)
  (dboard:runs-summary-xor-labels-updater tabdat)
(define (dboard:runs-summary-control-panel-updater commondat tabdat)
  (dboard:runs-summary-xor-labels-updater commondat tabdat)
  (dboard:runs-summary-buttons-updater tabdat))


;; setup buttons and callbacks to switch between modes in runs summary tab
;;
(define (dashboard:runs-summary-control-panel tabdat)
(define (dashboard:runs-summary-control-panel commondat tabdat)
  (let* ((summary-buttons ;; build buttons
          (map
           (lambda (mode-item)
             (let* ((this-mode (car mode-item))
                    (this-mode-label (cdr mode-item)))
               (iup:button this-mode-label
                           #:action
                           (lambda (obj)
                             (debug:catch-and-dump
                              (lambda ()
                                (dboard:tabdat-runs-summary-mode-set! tabdat this-mode)
                                (dboard:runs-summary-control-panel-updater tabdat))
                                (dboard:runs-summary-control-panel-updater commondattabdat))
                              "runs summary control panel updater")))))
           (dboard:tabdat-runs-summary-modes tabdat)))
         (summary-buttons-hbox (apply iup:hbox summary-buttons))
         (xor-runname-labels-hbox
          (iup:hbox
           (let ((temp-label
                  (iup:label "" #:size "125x15" #:fontsize "10" )))
             (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label)
             temp-label
             )
           (let ((temp-label
                  (iup:label "" #:size "125x15" #:fontsize "10")))
             (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label)
             temp-label))))
    (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons)

    ;; maybe wrap in a frame
    (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox )))
      (dboard:runs-summary-control-panel-updater tabdat)
      (dboard:runs-summary-control-panel-updater commondat tabdat)
      res
      )))

;;======================================================================
;; R U N
;;======================================================================
;;
;; display and manage a single run at a time

;; This is the Run Summary tab
;; 
(define (dashboard:runs-summary commondat tabdat #!key (tab-num #f))
  (let* ((dbstruct     (dboard:get-dbstruct commondat #f))
  (let* ((update-mutex (dboard:commondat-update-mutex commondat))
	 (update-mutex (dboard:commondat-update-mutex commondat))
	 (tb      (iup:treebox
		   #:value 0
		   #:name "Runs"
		   #:expand "YES"
		   #:addexpanded "YES"
		   #:selection-cb
		   (lambda (obj id state)




︙


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

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








-
-
+
+


-
+

-
+

-
+




-
+









                           (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status)
                           ;; status is corrupted on Brandon's home machine.  will have to wait until after shutdown to see if it is still broken in PDX SLES
                           (let* ((toolpath (car (argv)))
                                  (key      (conc lin ":" col))
                                  (test-id   (hash-table-ref/default cell-lookup key -1))
                                  (run-id   (dboard:tabdat-curr-run-id tabdat))
                                  (run-info (mrmt:get-run-info run-id))
                                  (target   (mrmt:get-target run-id))
                                  (run-info (db:get-run-info dbstruct run-id))
                                  (target   (db:get-target dbstruct run-id))
                                  (runname  (db:get-value-by-header (db:get-rows run-info)
                                                                    (db:get-header run-info) "runname"))
				  (test-info  (mrmt:get-test-info-by-id run-id test-id))
				  (test-info  (db:get-test-info-by-id dbstruct run-id test-id))
                                  (test-name (db:test-get-testname test-info))
                                  (testpatt  (let ((tlast (mrmt:tasks-get-last target runname)))
                                  (testpatt  (let ((tlast (db:tasks-get-last dbstruct target runname)))
                                                (if tlast
                                                    (let ((tpatt (tasks:task-get-testpatt tlast)))
                                                    (let ((tpatt (tasks:task-get-testpatt tlast))) ;; tasks:task-get-testpatt is an accessor defined in task_records.scm
                                                      (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
                                                          "%"
                                                          tpatt))
                                                    "%")))
                                  (item-path (db:test-get-item-path (mrmt:get-test-info-by-id run-id test-id)))
                                  (item-path (db:test-get-item-path (db:get-test-info-by-id dbstruct run-id test-id)))
                                  (item-test-path (conc test-name "/" (if (equal? item-path "")
									"%" 
									item-path)))
                                  (status-chars (char-set->list (string->char-set status)))
                                  (testpanel-cmd      (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &")))
                             (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]")
                             (cond




︙


2162
2163
2164
2165
2166
2167
2168
2169

2170
2171
2172
2173
2174
2175
2176

2152
2153
2154
2155
2156
2157
2158

2159
2160
2161
2162
2163
2164
2165
2166








-
+








                 (debug:catch-and-dump
                  (lambda () ;; check that run-matrix is initialized before calling the updater
		    (if run-matrix 
			(dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)))
                  "dashboard:runs-summary-updater")
                 )
	    (mutex-unlock! update-mutex)))
         (runs-summary-control-panel (dashboard:runs-summary-control-panel tabdat))
         (runs-summary-control-panel (dashboard:runs-summary-control-panel commondat tabdat))
         )
    (dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num)
    (dboard:tabdat-runs-tree-set! tabdat tb)
    (iup:vbox
     (iup:split
      #:value 200
      tb




︙


2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469

2445
2446
2447
2448
2449
2450
2451

2452
2453
2454
2455
2456
2457
2458








-








    (lambda (obj)
      (dcommon:examine-xterm run-id test-id)))

   (iup:menu-item
    (conc "Kill " item-test-path)
    #:action
    (lambda (obj)
      ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
      (common:run-a-command
       (conc "megatest -set-state-status KILLREQ,n/a -target " target
             " -runname " runname
             " -testpatt " item-test-path 
             " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))

   




︙


2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542

2517
2518
2519
2520
2521
2522
2523

2524
2525
2526
2527
2528
2529
2530








-








               " -runname " runname
	       " -testpatt " item-test-path
	       " -preclean -clean-cache"))))
     (iup:menu-item
      (conc "Kill " item-test-path)
      #:action
      (lambda (obj)
        ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
	(common:run-a-command
	 (conc "megatest -set-state-status KILLREQ,n/a -target " target
               " -runname " runname
	       " -testpatt " item-test-path 
	       " -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))
     (iup:menu-item
      (conc "Delete data : " item-test-path)




︙


2577
2578
2579
2580
2581
2582
2583

2584
2585
2586
2587
2588
2589






2590
2591
2592
2593
2594
2595
2596

2565
2566
2567
2568
2569
2570
2571
2572






2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585








+
-
-
-
-
-
-
+
+
+
+
+
+








			      (conc "xterm -e " editor)
			      editor)
			  " " tconfig " &")))
	  (system cmd))))
     ))))

(define (make-dashboard-buttons commondat) ;;  runs-sum-dat new-view-dat)
  (let* ((dbstruct        (dboard:get-dbstruct commondat #f))
  (let* ((stats-dat       (dboard:tabdat-make-data))
	 (runs-dat        (dboard:tabdat-make-data))
	 (onerun-dat      (dboard:tabdat-make-data)) ;; name for run-summary structure 
	 (runcontrols-dat (dboard:tabdat-make-data))
	 (runtimes-dat    (dboard:tabdat-make-data))
	 (areas-dat       (dboard:tabdat-make-data))
	 (stats-dat       (dboard:tabdat-make-data commondat))
	 (runs-dat        (dboard:tabdat-make-data commondat))
	 (onerun-dat      (dboard:tabdat-make-data commondat)) ;; name for run-summary structure 
	 (runcontrols-dat (dboard:tabdat-make-data commondat))
	 (runtimes-dat    (dboard:tabdat-make-data commondat))
	 (areas-dat       (dboard:tabdat-make-data commondat))
	 (nruns           (dboard:tabdat-numruns runs-dat))
	 (ntests          (dboard:tabdat-num-tests runs-dat))
	 (keynames        (dboard:tabdat-dbkeys runs-dat))
	 (nkeys           (length keynames))
	 (runsvec         (make-vector nruns))
	 (header          (make-vector nruns))
	 (lftcol          (make-vector ntests))




︙


2627
2628
2629
2630
2631
2632
2633
2634

2635
2636
2637
2638
2639
2640
2641

2616
2617
2618
2619
2620
2621
2622

2623
2624
2625
2626
2627
2628
2629
2630








-
+








    (let loop ((testnum  0)
	       (res      '()))
      (cond
       ((>= testnum ntests)
	;; now lftlst will be an hbox with the test keys and the test name labels
	(set! lftlst (append lftlst (list (iup:hbox  #:expand "HORIZONTAL"
						     (iup:valuator #:valuechanged_cb (lambda (obj)
										       (let ((val (string->number (iup:attribute obj "VALUE")))
	668									       (let ((val (string->number (iup:attribute obj "VALUE")))
											     (oldmax  (string->number (iup:attribute obj "MAX")))
											     (newmax  (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
											 (dboard:commondat-please-update-set! commondat #t)
											 (dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10))))
											 (debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) " (dboard:tabdat-start-test-offset runs-dat) " val: " val " newmax: " newmax " oldmax: " oldmax)
											 (if (< val 10)
											     (iup:attribute-set! obj "MAX" newmax))




︙


2697
2698
2699
2700
2701
2702
2703
2704
2705


2706
2707
2708

2709
2710

2711
2712
2713
2714
2715
2716
2717

2718
2719
2720
2721
2722
2723
2724

2686
2687
2688
2689
2690
2691
2692


2693
2694
2695
2696

2697
2698

2699
2700
2701
2702
2703
2704
2705

2706
2707
2708
2709
2710
2711
2712
2713








-
-
+
+


-
+

-
+






-
+








			      ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn))
			      (if  (substring-index "3" btn)
				   (if (eq? pressed 1)
				       (let* ((toolpath (car (argv)))
					      (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key))
					      (test-id  (db:test-get-id (vector-ref buttndat 3)))
					      (run-id   (db:test-get-run_id (vector-ref buttndat 3)))
					      (run-info (mrmt:get-run-info run-id))
					      (target   (mrmt:get-target run-id))
					      (run-info (db:get-run-info dbstruct run-id))
					      (target   (db:get-target dbstruct run-id))
					      (runname  (db:get-value-by-header (db:get-rows run-info)
										(db:get-header run-info) "runname"))
					      (test-info (mrmt:get-test-info-by-id run-id test-id))
					      (test-info (db:get-test-info-by-id dbstruct run-id test-id))
					      (test-name (db:test-get-testname test-info))
					      (testpatt  (let ((tlast (mrmt:tasks-get-last target runname)))
					      (testpatt  (let ((tlast (db:tasks-get-last dbstruct target runname)))
							   (if tlast
							       (let ((tpatt (tasks:task-get-testpatt tlast)))
								 (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
								     "%"
								     tpatt))
							       "%")))
                                              (item-path (db:test-get-item-path (mrmt:get-test-info-by-id run-id test-id)))
                                              (item-path (db:test-get-item-path (db:get-test-info-by-id dbstruct run-id test-id)))
                                              (item-test-path (conc test-name "/" (if (equal? item-path "")
									"%" 
									item-path))))
					 (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
						   #:x 'mouse
						   #:y 'mouse
						   #:modal? "NO")




︙


3002
3003
3004
3005
3006
3007
3008

3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
















3026
3027

3028
3029
3030
3031
3032
3033
3034

2991
2992
2993
2994
2995
2996
2997
2998
2999
















3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016

3017
3018
3019
3020
3021
3022
3023
3024








+

-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

-
+








		(< (db:test-get-event_time (hash-table-ref testsdat (car a)))
		   (db:test-get-event_time (hash-table-ref testsdat (car b))))))))))

;; run times tab data updater
;;
(define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
  (let* ((access-mode      (dboard:tabdat-access-mode tabdat))
	 (dbstruct         (dboard:get-dbstruct commondat #f))
         (last-runs-update (dboard:tabdat-last-runs-update tabdat))
         (runs-dat      (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header   (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
	 (runs-hash     (let ((ht (make-hash-table)))
			  (for-each (lambda (run)
				      (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
				    (vector-ref runs-dat 1))
			  ht))
	 (run-ids       (sort (filter number? (hash-table-keys runs-hash))
			      (lambda (a b)
				(let* ((record-a (hash-table-ref runs-hash a))
				       (record-b (hash-table-ref runs-hash b))
				       (time-a   (db:get-value-by-header record-a runs-header "event_time"))
				       (time-b   (db:get-value-by-header record-b runs-header "event_time")))
				  (< time-a time-b)))))
	 (tb            (dboard:tabdat-runs-tree tabdat))
	 (num-runs      (length (hash-table-keys runs-hash)))
         (runs-dat         (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header      (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
	 (runs-hash        (let ((ht (make-hash-table)))
			     (for-each (lambda (run)
					 (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
				       (vector-ref runs-dat 1))
			     ht))
	 (run-ids          (sort (filter number? (hash-table-keys runs-hash))
				 (lambda (a b)
				   (let* ((record-a (hash-table-ref runs-hash a))
					  (record-b (hash-table-ref runs-hash b))
					  (time-a   (db:get-value-by-header record-a runs-header "event_time"))
					  (time-b   (db:get-value-by-header record-b runs-header "event_time")))
				     (< time-a time-b)))))
	 (tb               (dboard:tabdat-runs-tree tabdat))
	 (num-runs         (length (hash-table-keys runs-hash)))
	 (update-start-time (current-seconds))
	 (inc-mode      #f))
	 (inc-mode         #f))
    (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
    ;; fill in the tree
    (if (and tb 
	     (not inc-mode))
	(for-each
	 (lambda (run-id)
	   (let* ((run-record (hash-table-ref/default runs-hash run-id #f))




︙


3075
3076
3077
3078
3079
3080
3081
3082


3083
3084
3085
3086
3087
3088
3089

3065
3066
3067
3068
3069
3070
3071

3072
3073
3074
3075
3076
3077
3078
3079
3080








-
+
+








		(vg:drawing-libs-set! dwg (make-hash-table))
		(vg:drawing-insts-set! dwg (make-hash-table))
		(vg:drawing-cache-set! dwg '())
		(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
		;; (dboard:tabdat-allruns-set! tabdat '())
		(dboard:tabdat-max-row-set! tabdat 0)
		(dboard:tabdat-last-filter-str-set! tabdat filtrstr)))
	  (update-rundat tabdat
	  (update-rundat commondat
			 tabdat
			 runpatt
			 ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") 
			 (dboard:tabdat-numruns tabdat)
			 testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
			 ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
			 
			 targpatt




︙


3544
3545
3546
3547
3548
3549
3550
3551

3552

3553
3554
3555
3556
3557
3558
3559

3535
3536
3537
3538
3539
3540
3541

3542
3543
3544
3545
3546
3547
3548
3549
3550
3551








-
+

+








;; 
;;  removing the tabdat-values proc 
;;
;; (define (tabdat-values tabdat)

;; runs update-rundat using the various filters from the gui
;;
(define (dashboard:do-update-rundat tabdat)
(define (dashboard:do-update-rundat commondat tabdat)
  (dboard:update-rundat
   commondat
   tabdat
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
   (dboard:tabdat-numruns tabdat)
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
   ;; generate key patterns from the target stored in tabdat
   (let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
     (let ((fres   (if (dboard:tabdat-target tabdat)




︙


3573
3574
3575
3576
3577
3578
3579
3580

3581
3582
3583
3584
3585
3586
3587

3565
3566
3567
3568
3569
3570
3571

3572
3573
3574
3575
3576
3577
3578
3579








-
+








   (lambda ()
     (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
	    (dbkeys (dboard:tabdat-dbkeys tabdat)))
       ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num)
       ;;(tabdat-values tabdat) ;;RA added 
       ;; (pp (dboard:tabdat->alist tabdat))
       ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat)      
       (dashboard:do-update-rundat tabdat)
       (dashboard:do-update-rundat commondat tabdat)
       ;;(debug:print-info 13 *default-log-port* "dashboard:runs-tab-updater")
       ;;(inspect tabdat)

       (let ((uidat (dboard:commondat-uidat commondat)))
	 ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat)
	 (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
       ))




︙







Modified db.scm
from [bfb6181eca]
to [63a31f1c8b].




︙


84
85
86
87
88
89
90
91

92
93
94
95
96
97
98

84
85
86
87
88
89
90

91
92
93
94
95
96
97
98








-
+








;;   NOTE: This does do a sync (the db:open-db proc only does an initial sync if called with do-sync: #t
;;   NOTE: Longer term consider replacing db:open-db with this
;;
;; NOTE: loose ends!!
;;    db:open-db              -> not properly using tmpdb path
;;    common:get-db-tmp-area  -> using *toppath* and common:get-testsuite-area
;;    
(define (db:dashboard-open-db areas area-name area-path)
(define (db:dashboard-open-dbstruct areas area-name area-path)
  ;; 0. check for already existing dbstruct in areas hash, return it if found
  ;; 1. do minimal read of megatest.config, store configdat, keys in dbstruct
  ;; 2. get homehost
  ;; 3. create /tmp db area  (if needed)
  ;; 4. sync data to /tmp db (or update if exists)
  ;; 5. return dbstruct
  (if (hash-table-exists? areas area-name)




︙







Added get-config-settings.sh version [3a902c0f68].






1
2

+
+

 grep configf:lookup *.scm | sed 's/^.*:lookup//; s/^-number//; s/^ //' | grep -v '^\(section\|test-conf\|tconfig\|testconfig\|dat\|config\|views-cfgdat\)' | perl -pe 's/^\s*(\*configdat\*|configdat|mtconf)//; s/^\s+//; s/\).*$//; s/"//g' | awk '{print $1,$2}' | sort | grep -v section | sort | uniq









Modified launch.scm
from [d2bf0c2411]
to [0c1e4ef13e].




︙


449
450
451
452
453
454
455
456

457
458
459
460
461
462
463

449
450
451
452
453
454
455

456
457
458
459
460
461
462
463








-
+








	       (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo))
	       (keys      #f)
	       (keyvals   #f)
	       (fullrunscript (if (not runscript)
                                  #f
                                  (if (substring-index "/" runscript)
                                      runscript ;; use unadultered if contains slashes
                                      (let ((fulln (conc testpath "/" runscript)))
                                      (let ((fulln (conc work-area "/" runscript)))
	                                  (if (and (common:file-exists? fulln)
                                                   (file-execute-access? fulln))
                                              fulln
                                              runscript))))) ;; assume it is on the path
	       ) ;; (rollup-status 0)

	  (if contour (setenv "MT_CONTOUR" contour))




︙


515
516
517
518
519
520
521
522

523
524

525
526

527
528




























529
530
531
532
533
534
535

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








-
+

-
+

-
+


+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








	;;    	  (handle-exceptions
	;;    	      exn
	;;    	      (debug:print 0 *default-log-port* "Failed to create directory " logdir " expect problems, message: " ((condition-property-accessor 'exn 'message) exn))
	;;    	    (create-directory logdir #t)))))
	;;    	  
	  ;; NFS might not have propagated the directory meta data to the run host - give it time if needed
	  (let loop ((count 0))
	    (if (or (common:file-exists? top-path)
	    (if (or (common:directory-exists? work-area)
		    (> count 10))
		(change-directory top-path)
		(change-directory work-area)
		(begin
		  (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " top-path " not found")
		  (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found")
		  (thread-sleep! 10)
		  (loop (+ count 1)))))

          (if (not (string=?  (common:real-path work-area)(common:real-path (current-directory))))
              (begin
                (debug:print 0 *default-log-port*
                             "INFO: we are expecting to be in directory " work-area "\n"
                             "     but we are actually in the directory " (current-directory) "\n"
                             "     doing another change dir.")
                (change-directory work-area)))
          
	  ;; spot check that the files in testpath are available. Too often NFS delays cause problems here.
	  (let ((files      (glob (conc testpath "/*")))
		(bad-files '()))
	    (for-each
	     (lambda (fullname)
	       (let* ((fname (pathname-strip-directory fullname))
                      (targn (conc work-area "/" fname)))
		 (if (not (file-exists? targn))
		     (set! bad-files (cons fname bad-files)))))
	     files)
	    (if (not (null? bad-files))
                (begin
                  (debug:print 0 *default-log-port* "INFO: test data from " testpath " not copied properly or filesystem problems causing data to not be found. Re-running the copy command.")
                  (debug:print 0 *default-log-port* "INFO: missing files from " work-area ": " (string-intersperse bad-files ", "))
                  (launch:test-copy testpath work-area))))

          ;; one more time, change to the work-area directory
          (change-directory work-area)
          
	  (launch:setup) ;; should be properly in the top-path now
	  (set! tconfigreg (tests:get-all))
	  (let ((sighand (lambda (signum)
			   ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
			   (if (eq? signum signal/stop)
			       (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting."))
			   (set! *time-to-exit* #t)




︙


557
558
559
560
561
562
563

564

565
566
567
568
569
570
571

585
586
587
588
589
590
591
592

593
594
595
596
597
598
599
600








+
-
+








		 (test-host (if test-info
				(db:test-get-host        test-info)
				(begin
				  (debug:print 0 *default-log-port* "ERROR: failed to find a record for test-id " test-id ", exiting.")
				  (exit))))
		 (test-pid  (db:test-get-process_id  test-info)))
	    (cond
             ;; -mrw- I'm removing KILLREQ from this list so that a test in KILLREQ state is treated as a "do not run" flag.
	     ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "KILLREQ" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
	     ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
	      (debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request")
	      ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
	      (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
	      ) ;; prime it for running
	     ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART"))
	      (if (process:alive-on-host? test-host test-pid)
		  (debug:print-error 0 *default-log-port* "test state is "  (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed")




︙


1067
1068
1069
1070
1071
1072
1073
















1074
1075
1076
1077
1078
1079
1080

1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








	(let ((res (common:get-disk-with-most-free-space disks minspace))) ;; min size of 1000, seems tad dumb
	  (if res
	      (cdr res)
	      (begin
		(if (common:low-noise-print 20 "No valid disks or no disk with enough space")
		    (debug:print-error 0 *default-log-port* "No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n    You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace))
		(exit 1))))))) ;; TODO - move the exit to the calling location and return #f

(define (launch:test-copy test-src-path test-path)
  (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd")))
		   (if cmd
		       ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH
		       (string-substitute "TEST_TARG_PATH" test-path
					  (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t)
		       #f)))
	 (cmd    (if ovrcmd 
		     ovrcmd
		     (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/"
			   " >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log")))
	 (status (system cmd)))
    (if (not (eq? status 0))
	(debug:print 2 *default-log-port* "ERROR: problem with running \"" cmd "\""))))


;; Desired directory structure:
;;
;;  <linkdir> - <target> - <testname> -.
;;                                     |
;;                                     v
;;  <rundir>  -  <target>  -    <testname> -|- <itempath(s)>




︙


1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243

1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258

1277
1278
1279
1280
1281
1282
1283





1284








1285
1286
1287
1288
1289
1290
1291








-
-
-
-
-
+
-
-
-
-
-
-
-
-








	   (if (not (common:file-exists? lnktarget)) (create-symbolic-link test-path lnktarget)))))

    (if (not (directory? test-path))
	(create-directory test-path #t)) ;; this is a hack, I don't know why out of the blue this path does not exist sometimes

    (if (and test-src-path (directory? test-path))
	(begin
	  (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd")))
			   (if cmd
			       ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH
			       (string-substitute "TEST_TARG_PATH" test-path
						  (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t)
	  (launch:test-copy test-src-path test-path)
			       #f)))
		 (cmd    (if ovrcmd 
			     ovrcmd
			     (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/"
				   " >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log")))
		 (status (system cmd)))
	    (if (not (eq? status 0))
		(debug:print 2 *default-log-port* "ERROR: problem with running \"" cmd "\"")))
	  (list lnkpathf lnkpath ))
	(if (and test-src-path (> remtries 0))
	    (begin
	      (debug:print-error 0 *default-log-port* "Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries)
	      ;; 
	      (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat remtries: (- remtries 1)))
	    (list #f #f)))))




︙







Modified megatest-version.scm
from [4677c6dd43]
to [ea84f1a115].



1
2
3
4
5
6

7

1
2
3
4
5

6
7






-
+


;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.6428)
(define megatest-version 1.6429)









Modified megatest.scm
from [d2c3028f31]
to [35786c6bf6].




︙


88
89
90
91
92
93
94
95

96
97
98
99
100
101
102

88
89
90
91
92
93
94

95
96
97
98
99
100
101
102








-
+








;;                            from prior runs with same keys
;;  -daemonize              : fork into background and disconnect from stdin/out

(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2017

 
Usage: megatest [options]
  -h                      : this help
  -manual                 : show the Megatest user manual
  -version                : print megatest version (currently " megatest-version ")

Launching and managing runs
  -run                    : run all tests or as specified by -testpatt




︙


112
113
114
115
116
117
118

119
120
121
122
123
124
125

112
113
114
115
116
117
118
119
120
121
122
123
124
125
126








+








  -unlock                 : unlock run specified by target and runname
  -set-run-status status  : sets status for run to status, requires -target and -runname
  -get-run-status         : gets status for run specified by target and runname
  -run-wait               : wait on run specified by target and runname
  -preclean               : remove the existing test directory before running the test
  -clean-cache            : remove the cached megatest.config and runconfigs.config files
  -no-cache               : do not use the cached config files. 
  -one-pass               : launch as many tests as you can but do not wait for more to be ready

Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.)
  -target key1/key2/...   : run for key1, key2, etc.
  -reqtarg key1/key2/...  : run for key1, key2, etc. but key1/key2 must be in runconfigs
  -testpatt patt1/patt2,patt3/...  : % is wildcard
  -runname                : required, name for this particular test run
  -state                  : Applies to runs, tests or steps depending on context




︙


345
346
347
348
349
350
351

352
353
354
355
356
357
358

346
347
348
349
350
351
352
353
354
355
356
357
358
359
360








+








			;; misc
			"-repl"
			"-lock"
			"-unlock"
			"-list-servers"
			"-kill-servers"
                        "-run-wait"      ;; wait on a run to complete (i.e. no RUNNING)
			"-one-pass"       ;;
			"-local"         ;; run some commands using local db access
                        "-generate-html"

			;; misc queries
			"-list-disks"
			"-list-targets"
			"-list-db-targets"




︙







Modified runs.scm
from [df9cc9bbed]
to [147cbc54ec].




︙


264
265
266
267
268
269
270







































271
272
273
274
275
276
277

264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








                   (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn))
                   (debug:print 0 *default-log-port* "ERROR: failed to run pre-hook " run-pre-hook ", check the log " log-file))
                 (debug:print-info 0 *default-log-port* "running run-pre-hook: \"" run-pre-hook "\", log is " actual-logf)
                 (system (conc run-pre-hook " >> " actual-logf " 2>&1"))
                 (debug:print-info 0 *default-log-port* "pre-hook \"" run-pre-hook "\" took " (- (current-seconds) start-time) " seconds to run.")))
              (debug:print 0 *default-log-port* "Skipping pre-hook call \"" run-pre-hook "\" as there are existing tests for this run.")))))
    
(define (runs:run-post-hook run-id)
    (let* ((run-post-hook   (configf:lookup *configdat* "runs" "post-hook"))
           (existing-tests (if run-post-hook
                               (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses
                                                      #f #f ;; offset limit
                                                      #f ;; not-in
                                                      #f ;; sort-by
                                                      #f ;; sort-order
                                                      #f ;; get full data (not 'shortlist)
                                                      0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
                                                      'dashboard)
                               '()))
           (log-dir         (conc *toppath* "/logs"))
           (log-file        (conc "post-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log"))
           (full-log-fname  (conc log-dir "/" log-file)))
      (if run-post-hook
          ;; (if (null? existing-tests)
          ;;    (debug:print 0 *default-log-port* "Skipping post-hook call \"" run-post-hook "\" as there are existing tests for this run.")))))
	  (let* ((use-log-dir (if (not (directory-exists? log-dir))
				  (handle-exceptions
				      exn
				      (begin
					(debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir)
					#f)
				    (create-directory log-dir #t)
				    #t)
				  #t))
		 (start-time   (current-seconds))
		 (actual-logf  (if use-log-dir full-log-fname log-file)))
	    (handle-exceptions
		exn
		(begin
		  (print-call-chain *default-log-port*)
		  (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn))
		  (debug:print 0 *default-log-port* "ERROR: failed to run post-hook " run-post-hook ", check the log " log-file))
	      (debug:print-info 0 *default-log-port* "running run-post-hook: \"" run-post-hook "\", log is " actual-logf)
	      (system (conc run-post-hook " >> " actual-logf " 2>&1"))
	      (debug:print-info 0 *default-log-port* "post-hook \"" run-post-hook "\" took " (- (current-seconds) start-time) " seconds to run."))))))

;;  test-names: Comma separated patterns same as test-patts but used in selection 
;;              of tests to run. The item portions are not respected.
;;              FIXME: error out if /patt specified
;;            
(define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names
  (let* ((keys               (keys:config-get-fields *configdat*))
	 (keyvals            (keys:target->keyval keys target))




︙


519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542

558
559
560
561
562
563
564










565
566
567
568
569
570
571








-
-
-
-
-
-
-
-
-
-








					    (handle-exceptions
						exn
						(begin
						  (print-call-chain)
						  (print " message: " ((condition-property-accessor 'exn 'message) exn)))
					      (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests
								    (any->number reglen) all-tests-registry)))
					    ;; (handle-exceptions
					    ;;  exn
					    ;;  (begin
					    ;;    (print-call-chain (current-error-port))
					    ;;    (debug:print-error 0 *default-log-port* "failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn))
					    ;;    (if (> run-queue-retries 0)
					    ;; 	   (begin
					    ;; 	     (set! run-queue-retries (- run-queue-retries 1))
					    ;; 	     (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))))
					    ;;  (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))
					  "runs:run-tests-queue"))
		 (th2        (make-thread (lambda ()				    
					    ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ...
					    (let ((run-ids (rmt:get-all-run-ids)))
					      (for-each (lambda (run-id)
							  (if keep-going
							      (handle-exceptions




︙


592
593
594
595
596
597
598








599
600
601
602
603
604
605

621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642








+
+
+
+
+
+
+
+








(define (runs:queue-next-reg tal reg n regfull)
  (if regfull
      (cdr reg)
      (if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal
	  '()
	  reg)))

;; this is the list of parameters to the named loop "loop" near the top of runs:run-tests-queue, look around line 1216
;;
(define (runs:loop-values tal reg reglen regfull reruns)
  (list (runs:queue-next-hed tal reg reglen regfull)      ;; hed
        (runs:queue-next-tal tal reg reglen regfull)      ;; tal
        (runs:queue-next-reg tal reg reglen regfull)      ;; reg
        reruns))                                          ;; reruns

(define runs:nothing-left-in-queue-count 0)

;; BB: for future reference - suspect target vars are not expanded to env vars at this point (item expansion using [items]\nwhatever [system echo $TARGETVAR] doesnt work right whereas [system echo #{targetvar}] does.. Tal and Randy have tix on this.  on first pass, var not set, on second pass, ok.  
(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps)
  (let* ((loop-list       (list hed tal reg reruns))
	 (prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)))
			    (if (list? res)




︙


634
635
636
637
638
639
640
641
642

643
644
645
646
647
648
649
650
651

671
672
673
674
675
676
677


678


679
680
681
682
683
684
685








-
-
+
-
-









     ((and (not (member 'toplevel testmode))
	   (member (hash-table-ref/default test-registry (db:test-make-full-name hed item-path) 'n/a)
		   '(DONOTRUN removed CANNOTRUN))) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here
      (debug:print-info 1 *default-log-port* "Test " hed " set to \"" (hash-table-ref test-registry (db:test-make-full-name hed item-path)) "\". Removing it from the queue")
      (if (or (not (null? tal))
	      (not (null? reg)))
	  (list (runs:queue-next-hed tal reg reglen regfull)
		(runs:queue-next-tal tal reg reglen regfull)
          (runs:loop-values tal reg reglen regfull reruns)
		(runs:queue-next-reg tal reg reglen regfull)
		reruns)
	  (begin
	    (debug:print-info 0 *default-log-port* "Nothing left in the queue!")
	    ;; If get here twice then we know we've tried to expand all items
	    ;; since there must be a logic issue with the handling of loops in the 
	    ;; items expand phase we will brute force an exit here.
	    (if (> runs:nothing-left-in-queue-count 2)
		(begin




︙


710
711
712
713
714
715
716
717
718

719
720

721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740

741
742

743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762


763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782

744
745
746
747
748
749
750


751


752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770


771


772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788




789
790
791
792
793
794
795
796
797
798
799




800
801
802
803
804
805
806








-
-
+
-
-
+


















-
-
+
-
-
+
















-
-
-
-
+
+









-
-
-
-









	      (let ((test-id (rmt:get-test-id run-id hed "")))
		(if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites")))
	      
	      (if (and (null? trimmed-tal)
		       (null? trimmed-reg))
		  #f
		  (list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull)
			(runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull)
                  (runs:loop-values trimmed-tal trimmed-reg reglen regfull reruns)
			(runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull)
			reruns)))
                  ))
	      (list (car newtal)(append (cdr newtal) reg) '() reruns))))

     ((and (null? fails)
	   (null? prereq-fails)
	   (null? non-completed))
      (if  (runs:can-keep-running? hed 20)
	  (begin
	    (runs:inc-cant-run-tests hed)
	    (debug:print-info 1 *default-log-port* "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0))
	    ;; getting here likely means the system is way overloaded, kill a full minute before continuing
	    (thread-sleep! 60)
	    ;; num-retries code was here
	    ;; we use this opportunity to move contents of reg to tal
	    (list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met?
	  (begin
	    (debug:print-info 1 *default-log-port* "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue")
	    (let ((test-id (rmt:get-test-id run-id hed "")))
	      (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "TIMED_OUT" "Nothing seen running in a while.")))
	    (list (runs:queue-next-hed tal reg reglen regfull)
		  (runs:queue-next-tal tal reg reglen regfull)
            (runs:loop-values tal reg reglen regfull reruns)
		  (runs:queue-next-reg tal reg reglen regfull)
		  reruns))))
            )))

     ((and 
       (or (not (null? fails))
	   (not (null? prereq-fails)))
       (member 'normal testmode))
      (debug:print-info 1 *default-log-port* "test "  hed " (mode=" testmode ") has failed prerequisite(s); "
			(string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ")
			", removing it from to-do list")
      (let ((test-id (rmt:get-test-id run-id hed "")))
	(if test-id
	    (if (not (null? prereq-fails))
		(mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites")
		(mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL"      "Failed to run due to failed prerequisites"))))
      (if (or (not (null? reg))(not (null? tal)))
	  (begin
	    (hash-table-set! test-registry hed 'CANNOTRUN)
	    (list (runs:queue-next-hed tal reg reglen regfull)
		  (runs:queue-next-tal tal reg reglen regfull)
		  (runs:queue-next-reg tal reg reglen regfull)
		  (cons hed reruns)))
            (runs:loop-values tal reg reglen regfull (cons hed reruns))
            )
	  #f)) ;; #f flags do not loop

     ((and (not (null? fails))(member 'toplevel testmode))
      (if (or (not (null? reg))(not (null? tal)))
	   (list (car newtal)(append (cdr newtal) reg) '() reruns)
	  #f)) 
     ((null? runnables) #f) ;; if we get here and non-completed is null then it is all over.
     (else
      (debug:print 0 *default-log-port* "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now")
      ;; (list (runs:queue-next-hed tal reg reglen regfull)
      ;;   	(runs:queue-next-tal tal reg reglen regfull)
      ;;   	(runs:queue-next-reg tal reg reglen regfull)
      ;;   	reruns)
      (list (car newtal)(cdr newtal) reg reruns)))))

(define (runs:mixed-list-testname-and-testrec->list-of-strings inlst)
  (if (null? inlst)
      '()
      (map (lambda (t)
	     (cond




︙


872
873
874
875
876
877
878
879
880

881
882
883
884
885
886
887
888
889

896
897
898
899
900
901
902


903


904
905
906
907
908
909
910








-
-
+
-
-








     ;; Check item path against item-patts, 
     ;;
     ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run
      ;; else the run is stuck, temporarily or permanently
      ;; but should check if it is due to lack of resources vs. prerequisites
      (debug:print-info 1 *default-log-port* "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts)
      (if (or (not (null? tal))(not (null? reg)))
	  (list (runs:queue-next-hed tal reg reglen regfull)
		(runs:queue-next-tal tal reg reglen regfull)
	  (runs:loop-values tal reg reglen regfull reruns)
		(runs:queue-next-reg tal reg reglen regfull)
		reruns)
	  #f))
     
     ;; Register tests 
     ;;
     ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f))
      (debug:print-info 4 *default-log-port* "Pre-registering test " test-name "/" item-path " to create placeholder" )
      ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs




︙


900
901
902
903
904
905
906
907

908
909
910
911
912
913
914

921
922
923
924
925
926
927

928
929
930
931
932
933
934
935








-
+








	  (begin
	    (rmt:register-test run-id test-name "")
	    (if (rmt:get-test-id run-id test-name "")
		(hash-table-set! test-registry (db:test-make-full-name test-name "") 'done))))
      (runs:shrink-can-run-more-tests-count runsdat)   ;; DELAY TWEAKER (still needed?)
      (if (and (null? tal)(null? reg))
	  (list hed tal (append reg (list hed)) reruns)
	  (list (runs:queue-next-hed tal reg reglen regfull)
	  (list (runs:queue-next-hed tal reg reglen regfull) ;; cannot replace with a call to runs:loop-values as the logic is different for reg
		(runs:queue-next-tal tal reg reglen regfull)
		;; NB// Here we are building reg as we register tests
		;; if regfull we must pop the front item off reg
		(if regfull
		    (append (cdr reg) (list hed))
		    (append reg (list hed)))
		reruns)))




︙


957
958
959
960
961
962
963
964
965

966
967
968
969
970
971
972
973
974

978
979
980
981
982
983
984


985


986
987
988
989
990
991
992








-
-
+
-
-








      
      (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry)
      (runs:incremental-print-results run-id)
      (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running)
      (runs:shrink-can-run-more-tests-count runsdat)  ;; DELAY TWEAKER (still needed?)
      ;; (thread-sleep! *global-delta*)
      (if (or (not (null? tal))(not (null? reg)))
	  (list (runs:queue-next-hed tal reg reglen regfull)
		(runs:queue-next-tal tal reg reglen regfull)
	  (runs:loop-values tal reg reglen regfull reruns)
		(runs:queue-next-reg tal reg reglen regfull)
		reruns)
	  #f))
     
     ;; must be we have unmet prerequisites
     ;;
     (else
      (debug:print 4 *default-log-port* "FAILS: " fails)
      ;; If one or more of the prereqs-not-met are FAIL then we can issue




︙


996
997
998
999
1000
1001
1002
1003
1004

1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015

1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032

1033
1034
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
1072
1073
1074
1075

1014
1015
1016
1017
1018
1019
1020


1021



1022
1023
1024
1025
1026
1027


1028


1029
1030
1031
1032
1033
1034
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
1072
1073
1074








-
-
+
-
-
-






-
-
+
-
-










-
-
-
-
-
+
-
-










-
-
+
-
-













-
+


-
-
+
-
-








		    (let ((test-id (rmt:get-test-id run-id hed "")))
		      (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))
		    (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)
		    ;; (thread-sleep! *global-delta*)
		    ;; This next is for the items
		    (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f)
		    (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'removed)
		    (list (runs:queue-next-hed tal reg reglen regfull)
			  (runs:queue-next-tal tal reg reglen regfull)
		    (runs:loop-values tal reg reglen regfull reruns))
			  (runs:queue-next-reg tal reg reglen regfull)
			  reruns ;; WAS: (cons hed reruns) ;; but that makes no sense?
			  ))
		  (let ((nth-try (hash-table-ref/default test-registry hed 0)))
		    (cond
		     ((member "RUNNING" (map db:test-get-state prereqs-not-met))
		      (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60)
			  (debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet."))
		      (thread-sleep! 4)
		      (list (runs:queue-next-hed newtal reg reglen regfull)
			    (runs:queue-next-tal newtal reg reglen regfull)
		      (runs:loop-values tal reg reglen regfull reruns))
			    (runs:queue-next-reg newtal reg reglen regfull)
			    reruns))
		     ((or (not nth-try)
			  (and (number? nth-try)
			       (< nth-try 10)))
		      (hash-table-set! test-registry hed (if (number? nth-try)
							     (+ nth-try 1)
							     0))
		      (if (runs:lownoise (conc "not removing test " hed) 60)
			  (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites"))
		      ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;;  " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")
		      (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)
		      ;; (list hed tal reg reruns)
		      ;; (list (car newtal)(cdr newtal) reg reruns)
		      ;; (hash-table-set! test-registry hed 'removed)
		      (list (runs:queue-next-hed newtal reg reglen regfull)
			    (runs:queue-next-tal newtal reg reglen regfull)
		      (runs:loop-values newtal reg reglen regfull reruns))
			    (runs:queue-next-reg newtal reg reglen regfull)
			    reruns))
		     ((symbol? nth-try)
		      (if (eq? nth-try 'removed) ;; removed is removed - drop it NOW
			  (if (null? tal)
			      #f ;; yes, really
			      (list (car tal)(cdr tal) reg reruns))
			  (begin
			    (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60)
				(debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry."))
			    (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f)
			    (hash-table-set! test-registry hed 0)
			    (list (runs:queue-next-hed newtal reg reglen regfull)
				  (runs:queue-next-tal newtal reg reglen regfull)
			    (runs:loop-values newtal reg reglen regfull))))
				  (runs:queue-next-reg newtal reg reglen regfull)
				  reruns))))
		     (else
		      (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60)
			  (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now."))
		      ;; (debug:print 0 *default-log-port* "         prereqs: " prereqs-not-met)
		      (hash-table-set! test-registry hed 'removed)
		      (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f)
		      ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug.
		      (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL
		      (list (if (null? tal)(car newtal)(car tal))
			    tal
			    reg
			    reruns)))))
	      ;; can't drop this - maybe running? Just keep trying
	      (let ((runable-tests (runs:runable-tests prereqs-not-met)))
	      (let ((runable-tests (runs:runable-tests prereqs-not-met))) ;; SUSPICIOUS: Should look at more than just prereqs-not-met?
		(if (null? runable-tests)
		    #f   ;; I think we are truly done here
		    (list (runs:queue-next-hed newtal reg reglen regfull)
			    (runs:queue-next-tal newtal reg reglen regfull)
		    (runs:loop-values newtal reg reglen regfull reruns)))))))))
			    (runs:queue-next-reg newtal reg reglen regfull)
			    reruns)))))))))

;; scan a list of tests looking to see if any are potentially runnable
;;
(define (runs:runable-tests tests)
  (filter (lambda (t)
	    (if (not (vector? t))
		t




︙


1466
1467
1468
1469
1470
1471
1472

1473
1474
1475
1476
1477
1478
1479

1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479








+








	    (if (not (eq? num-running prev-num-running))
		(debug:print-info 0 *default-log-port* "run-wait specified, waiting on " num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds)))))
	    (thread-sleep! 5)
	    ;; (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running))))
	    (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running))))
    ;; LET* ((test-record
    ;; we get here on "drop through". All done!
    (runs:run-post-hook run-id)
    (debug:print-info 1 *default-log-port* "All tests launched")))

(define (runs:calc-fails prereqs-not-met)
  (filter (lambda (test)
	    (and (vector? test) ;; not (string? test))
		 (member (db:test-get-state test) '("INCOMPLETE" "COMPLETED"))
		 (not (member (db:test-get-status test)




︙







Added show-uncalled-procedures.scm version [27f7128851].

















1
2
3
4
5
6
7
8
9
10
11
12
13

+
+
+
+
+
+
+
+
+
+
+
+
+

(include "codescanlib.scm")

(define (show-danglers)
  (let* ((all-scm-files (glob "*.scm"))
         (xref (get-xref all-scm-files))
         (dangling-procs
          (map car (filter (lambda (x) (equal? 1 (length x))) xref))))
    (for-each print dangling-procs) ;; our product.
    ))

(show-danglers)

    








Modified tcmt.scm
from [5f5e90a486]
to [75ab8b7c92].




︙


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
119
120

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
119
120
121








-
+
-

+











+








      ((COMPLETED)
       (if (not startp) ;; start stanza never printed
	   (begin
	     (print "##teamcity[testStarted " tcname flowid tstmp "]")
	     (testdat-start-printed-set! tdat #t)))
       (if (not endp)
	   (begin
	     (if (member status '(PASS WARN SKIP WAIVED))
	     (if (not (member status '(PASS WARN SKIP WAIVED)))
		 (print "##teamcity[testFinished" tcname flowid comment details duration "]")
		 (print "##teamcity[testFailed  " tcname flowid comment details "]"))
             (print "##teamcity[testFinished" tcname flowid comment details duration "]")
	     (testdat-end-printed-set! tdat #t))))
      (else
       (if flush-mode
	   (begin
	     (if (not startp)
		 (begin
		   (print "##teamcity[testStarted " tcname flowid tstmp "]")
		   (testdat-start-printed-set! tdat #t)))
	     (if (not endp)
		 (begin
		   (print "##teamcity[testFailed  " tcname flowid comment details "]")
                   (print "##teamcity[testFinished" tcname flowid comment details duration "]")
		   (testdat-end-printed-set! tdat #t)))))))
    ;; (print "ERROR: tc-type \"" (testdat-tc-type tdat) "\" not recognised for " tcname)))
    (flush-output)))

;; ;; returns values: flag newlst
;; (define (remove-duplicate-completed  tdats)
;;   (let* ((flag       #f)




︙







Added trackback.scm version [4011884617].








































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

(include "codescanlib.scm")

;; show call paths for named procedure
(define (traceback-proc in-procname)
  (letrec* ((all-scm-files (glob "*.scm"))
            (xref (get-xref all-scm-files))
            (have (alist-ref (string->symbol in-procname) xref eq? #f))
            (lookup (lambda (path procname depth)
                      (let* ((upcone-temp (filter (lambda (x)
                                                    (eq? procname (car x)))
                                                  xref))
                             (upcone-temp2 (cond
                                            ((null? upcone-temp) '())
                                            (else (cdar upcone-temp))))
                             (upcone (filter
                                      (lambda (x) (not (eq? x procname)))
                                      upcone-temp2))
                             (uppath (cons procname path))
                             (updepth (add1 depth)))
                        (if (null? upcone)
                            (print  uppath)
                            (for-each (lambda (x)
                                        (if (not (member procname path))
                                            (lookup uppath x updepth) ))
                                      upcone))))))
           (if have
               (lookup '() (string->symbol in-procname) 0)
               (print "no such func - "in-procname))))


(if (eq? 1 (length (command-line-arguments)))
    (traceback-proc (car (command-line-arguments)))
    (print "Usage: trackback <procedure name>"))

(exit 0)
    








Modified utils/plot-code.scm
from [2b66df6bfd]
to [6d50d1bd96].



1
2
3
4
5
6
7
8
9
10

11



12
13









14
15

16
17
18
19
20

21
22
23
24
25
26
27

1
2
3
4
5
6
7
8
9

10
11
12
13
14


15
16
17
18
19
20
21
22
23
24

25
26
27
28
29

30
31
32
33
34
35
36
37










-
+

+
+
+
-
-
+
+
+
+
+
+
+
+
+

-
+




-
+








#!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq

;; Coming soon (right?) Usage: plot-code file1.scm,file2.scm "fun1,fun2,x*" *.scm > plot.dot
;; Usage: plot-code file1.scm,file2.scm *.scm > plot.dot
;;        dot -Tpdf plot.dot > plot.pdf
;; first param is comma separated list of files to include in the map, use - to do all
;; second param is list of regexs for functions to include in the map
;; third param is list of files to scan

(use regex srfi-69 srfi-13)
(use regex srfi-69 srfi-13 srfi-1 data-structures posix)

;;                 1                   2        remainder
;; plot-code file1.scm,file2.scm... fn-regex file1.scm file2.scm ...

(define targs #f) 
(define files (cdr (cddddr (argv))))
(define targs #f)

(define args (argv))
(if (< (length args) 2) ;; no args provided
    (begin
       (print "Usage: plot-code file1.scm,file2.scm... 'your.*regex' file3.scm file4.scm file5.scm  ...")
       (exit)))

(define files (cdddr args))

(let ((targdat (cadddr (argv))))
(let ((targdat (cadr args)))
  (if (equal? targdat "-")
      (set! targs files)
      (set! targs (string-split targdat ","))))

(define function-patt (car (cdr (cdddr (argv)))))
(define function-patt (caddr args))
(define function-rx   (regexp function-patt))
(define filedat-defns (make-hash-table))
(define filedat-usages (make-hash-table))

(define defn-rx (regexp "^\\s*\\(define\\s+\\(([^\\s\\)]+).*"))
(define all-regexs (make-hash-table))





︙







Added utils/whodunit.scm version [862906085a].




















































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

(use posix srfi-69)

(define *numsamples* (or (and (> (length (argv)) 1)
                              (string->number (cadr (argv))))
                         3))

(define (topdata)
  (with-input-from-pipe
   (conc "top -b -n " *numsamples* " -d 0.1")
   read-lines))

(define (cleanup-data topdat)list
  (let loop ((hed (car topdat))
              (tal (cdr topdat))
              (res '()))
    (let* ((line-list (string-split hed))
           (nums      (map (lambda (indat)(or (string->number indat) indat)) line-list))
           (not-data  (or (null? nums)
                          (not (number? (car nums)))))
           (new-res   (if not-data res (cons nums res))))
      (if (null? tal)
          new-res
          (loop (car tal)(cdr tal) new-res)))))

(print "Getting " *numsamples* " samples of cpu usage data.")
(define data (cleanup-data (topdata)))
(define pidhash  (make-hash-table))
(define userhash (make-hash-table))

;; sum up and normalize the 
(for-each
 (lambda (indat)
   (let ((pid (car indat))
         (usr (cadr indat))
         (cpu (list-ref indat 8)))
     (hash-table-set! userhash usr (+ cpu (hash-table-ref/default userhash usr 0)))))
 data)

(for-each
 (lambda (usr)
   (print usr
          (if (< (string-length usr) 8) "\t\t" "\t")
          (inexact->exact (round (/ (hash-table-ref userhash usr) *numsamples*)))))
 (sort (hash-table-keys userhash)
       (lambda (a b)
         (> (hash-table-ref userhash a)
            (hash-table-ref userhash b)))))












This page was generated in about
0.124s by
Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00