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 | (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* | | | 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 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 | ;; 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"))) | | | 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 #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 | ;;====================================================================== ;; 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 | | | | | 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 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 commondat tabdat) ;; )
;; (dboard:areas-summary-control-panel-updater tabdat)
;; (let* ((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: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 | ;; 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 | > | | | | | | | 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))
(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 (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 (db:get-test-info-by-id dbstruct run-id test-id))
(test-name (db:test-get-testname test-info))
(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 (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 | (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))) | | | > | | | 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 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 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 (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 (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 | (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)) | | | 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 (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 |
(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
;;
| | > | > | | 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 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 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 (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 |
;; 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)
| | | 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-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 |
;; ;; 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
))
| | | | > | | | | 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 dbstruct run-id tabdat runs-hash)
(let* ((run (hash-table-ref/default runs-hash run-id #f))
(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 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 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 |
(lambda (obj)
(dcommon:examine-xterm run-id test-id)))
(iup:menu-item
(conc "Kill " item-test-path)
#:action
(lambda (obj)
| < | 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)
(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 |
" -runname " runname
" -testpatt " item-test-path
" -preclean -clean-cache"))))
(iup:menu-item
(conc "Kill " item-test-path)
#:action
(lambda (obj)
| < | 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)
(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 |
(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
;;
| | | | | | | | | > | | | 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 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 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 commondat tabdat)
res
)))
(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 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))
(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
(db:get-run-name-from-id dbstruct curr-run-id)
"None"))
(prev-runname (if 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 | (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 " | | < | 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-2017 Usage: dashboard [options] -h : this help -test run-id,test-id : control test identified by testid -skip-version-check : skip the version check 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 | ) (list "-h" "-use-server" "-guimonitor" "-main" "-v" "-q" | | | 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"
"-skip-version-check"
"-repl"
"-rh5.11" ;; fix to allow running on rh5.11
)
args:arg-hash
0))
|
| ︙ | ︙ | |||
145 146 147 148 149 150 151 | 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) | | > > > > > > > > > > | | 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)
(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 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 | (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))) | | | | > | | | | | | | | | | 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 commondat)
(let ((dat (make-dboard:tabdat)))
(dboard:setup-tabdat commondat dat)
(dboard:setup-num-rows dat)
dat))
(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 (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 | (define (dboard:runsdat-make-init) (make-dboard:runsdat runs-index: (make-hash-table) tests-index: (make-hash-table) matrix-dat: (make-sparse-array))) | | | 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 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 | ;; 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 ;; | | > | | 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 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 |
;;(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)
| | | | 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 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)
(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 | ;; 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 "%") ) ;; | | > | | | < | | 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 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 (db:get-runs dbstruct runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
(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 | (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)) | | | | 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 (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 |
(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 "%") )
;;
| | > | | | | | | 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 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 (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 | (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)) | | | | 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 (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 |
(if val
val
(if (not (null? values))
(let ((newval (car values)))
(iup:attribute-set! lb "VALUE" newval)
newval))))))
| | > | | | 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 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 (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 | ;;====================================================================== ;; R U N C O N T R O L S ;;====================================================================== ;; ;; A gui for launching tests ;; | | | | > | | | 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 commondat tabdat) ;; key-listboxes)
(let ((targ (map (lambda (x)
(iup:attribute x "VALUE"))
(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 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 (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 | (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" | | | 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 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 |
;; 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)
| | | 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 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 | (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 () | | | 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 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 |
;; 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))
| < < < < < < < < < < < < < < < < < < < < < < < < < < | | 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 (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 (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 |
(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)))))))
| | > | | | > | | | | > | | | > | | | | | | < < < < < < | | | | | < | 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 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 (db:get-key-vals dbstruct run-id))
(testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
(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 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 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 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 (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 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)))
(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 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))
(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 | ;;====================================================================== ;; 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)) | > > > | | 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)
;; (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 |
(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))))))
| | | | > | | | | | | | > | | 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 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))
(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
(db:get-run-name-from-id dbstruct curr-run-id)
"None"))
(prev-runname (if 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 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 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 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 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))
(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 |
(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))
| | | | | | | | 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 (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 (db:get-test-info-by-id dbstruct run-id test-id))
(test-name (db:test-get-testname test-info))
(testpatt (let ((tlast (db:tasks-get-last dbstruct target runname)))
(if 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 (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 |
(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)))
| | | 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 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 |
(lambda (obj)
(dcommon:examine-xterm run-id test-id)))
(iup:menu-item
(conc "Kill " item-test-path)
#:action
(lambda (obj)
| < | 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)
(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 |
" -runname " runname
" -testpatt " item-test-path
" -preclean -clean-cache"))))
(iup:menu-item
(conc "Kill " item-test-path)
#:action
(lambda (obj)
| < | 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)
(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 |
(conc "xterm -e " editor)
editor)
" " tconfig " &")))
(system cmd))))
))))
(define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat)
| > | | | | | | | 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))
(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 |
(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)
| | | 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)
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 | ;; (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))) | | | | | | | 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 (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 (db:get-test-info-by-id dbstruct run-id test-id))
(test-name (db:test-get-testname test-info))
(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 (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 |
(< (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))
(last-runs-update (dboard:tabdat-last-runs-update tabdat))
| > | | | | | | | | | | | | | | | | | | 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 (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))
(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 | (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))) | | > | 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 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 | ;; ;; removing the tabdat-values proc ;; ;; (define (tabdat-values tabdat) ;; runs update-rundat using the various filters from the gui ;; | | > | 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 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 |
(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)
| | | 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 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 | ;; 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 ;; | | | 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-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 |
(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
| | | 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 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 | ;; (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)) | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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:directory-exists? work-area)
(> count 10))
(change-directory work-area)
(begin
(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 | (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 | > | | 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" "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 | (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 ;; Desired directory structure: ;; ;; <linkdir> - <target> - <testname> -. ;; | ;; v ;; <rundir> - <target> - <testname> -|- <itempath(s)> | > > > > > > > > > > > > > > > > | 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 |
(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
| < < < < | < < < < < < < < | 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
(launch:test-copy test-src-path test-path)
(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 | ;; 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)) | | | 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.6429) |
Modified megatest.scm from [d2c3028f31] to [35786c6bf6].
| ︙ | ︙ | |||
88 89 90 91 92 93 94 | ;; 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 | | | 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 | -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. 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 | > | 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 |
;; misc
"-repl"
"-lock"
"-unlock"
"-list-servers"
"-kill-servers"
"-run-wait" ;; wait on a run to complete (i.e. no RUNNING)
"-local" ;; run some commands using local db access
"-generate-html"
;; misc queries
"-list-disks"
"-list-targets"
"-list-db-targets"
| > | 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 |
(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.")))))
;; 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))
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (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))) | < < < < < < < < < < | 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))) "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 |
(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)))
(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)
| > > > > > > > > | 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 |
((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)))
| < | < < | 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)))
(runs:loop-values 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 | (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 | < | < | < | < | < < < | > < < < < | 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
(runs:loop-values 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.")))
(runs:loop-values 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)
(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 (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 |
;; 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)))
| < | < < | 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)))
(runs:loop-values 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 |
(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)
| | | 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) ;; 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 |
(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)))
| < | < < | 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)))
(runs:loop-values 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 | (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) | < | < < < < | < < < < < < | < < < | < < | < | < < | 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) (runs:loop-values tal reg reglen regfull reruns)) (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) (runs:loop-values tal 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?) (runs:loop-values 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) (runs:loop-values newtal reg reglen regfull)))) (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))) ;; SUSPICIOUS: Should look at more than just prereqs-not-met? (if (null? runable-tests) #f ;; I think we are truly done here (runs:loop-values 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 |
(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!
(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)
| > | 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 |
((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
| | < > > | 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 (not (member status '(PASS WARN SKIP WAIVED)))
(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 | #!/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 | | > > > | > > > > > > > | | | | 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 srfi-1 data-structures posix)
;; 1 2 remainder
;; plot-code file1.scm,file2.scm... fn-regex file1.scm file2.scm ...
(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 (cadr args)))
(if (equal? targdat "-")
(set! targs files)
(set! targs (string-split targdat ","))))
(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)))))
|