Megatest

Changes On Branch d1e28c26f91d5ded
Login

Changes In Branch matt-db-sync Through [d1e28c26f9] Excluding Merge-Ins

This is equivalent to a diff from 482aa5f1dd to d1e28c26f9

2016-10-28
18:04
Added a color to hex function check-in: 955fb16781 user: mrwellan tags: matt-db-sync
15:15
Partial fixes for sync from multi-db to megatest.db check-in: d1e28c26f9 user: mrwellan tags: matt-db-sync
08:52
Made use of cached db optional for list-runs. Merged in minor fix from v1.62 Closed-Leaf check-in: 482aa5f1dd user: mrwellan tags: cached-copy-srehman
2016-10-27
23:52
Converted -list-runs to use cached db check-in: cbeea6e758 user: matt tags: cached-copy-srehman
20:55
Fixed bad call to rmt:get-runs-by-patt in megatest.scm check-in: 2e18664666 user: matt tags: v1.62

Modified common.scm from [c162c68a8a] to [5539c56e2c].

166
167
168
169
170
171
172
173

174
175
176
177
178
179
180
  (db:multi-db-sync 
   #f ;; do all run-ids
   ;; 'new2old
   'killservers
   'dejunk
   ;; 'adj-testids
   ;; 'old2new
   'new2old)

  (if (common:version-changed?)
      (common:set-last-run-version)))

;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
;;
(define (common:exit-on-version-changed)
  (if (common:version-changed?)







|
>







166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
  (db:multi-db-sync 
   #f ;; do all run-ids
   ;; 'new2old
   'killservers
   'dejunk
   ;; 'adj-testids
   ;; 'old2new
   'new2old
   'schema)
  (if (common:version-changed?)
      (common:set-last-run-version)))

;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
;;
(define (common:exit-on-version-changed)
  (if (common:version-changed?)
375
376
377
378
379
380
381

382
383
384
385


































386
387
388
389
390
391
392

(define (common:legacy-sync-recommended)
  (or (args:get-arg "-runtests")
      (args:get-arg "-server")
      ;; (args:get-arg "-set-run-status")
      (args:get-arg "-remove-runs")
      ;; (args:get-arg "-get-run-status")

      ))

(define (common:legacy-sync-required)
  (configf:lookup *configdat* "setup" "megatest-db"))



































(define (std-exit-procedure)
  (let ((no-hurry  (if *time-to-exit* ;; hurry up
		       #f
		       (begin
			 (set! *time-to-exit* #t)
			 #t))))







>




>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428

(define (common:legacy-sync-recommended)
  (or (args:get-arg "-runtests")
      (args:get-arg "-server")
      ;; (args:get-arg "-set-run-status")
      (args:get-arg "-remove-runs")
      ;; (args:get-arg "-get-run-status")
      (args:get-arg "-use-db-cache") ;; feels like a bad idea ...
      ))

(define (common:legacy-sync-required)
  (configf:lookup *configdat* "setup" "megatest-db"))

;; run-ids
;;    if #f use *db-local-sync*
;;    if #t use timestamps
(define (common:sync-to-megatest.db run-ids) 
  (let ((start-time         (current-seconds))
        (run-ids-to-process (if (list? run-ids)
                                run-ids
                                (if run-ids
                                    (db:get-changed-run-ids (let* ((mtdb-fpath (conc *toppath* "/megatest.db"))
                                                                   (mtdb-exists (file-exists? mtdb-fpath)))
                                                              (if mtdb-exists
                                                                  (file-modification-time mtdb-fpath)
                                                                  0)))
                                    (hash-table-keys *db-local-sync*)))))
    (debug:print-info 4 *default-log-port* "Processing run-ids: " run-ids-to-process)
    (for-each 
     (lambda (run-id)
       (mutex-lock! *db-multi-sync-mutex*)
       (if (or run-ids ;; if we were provided with run-ids, proceed
               (hash-table-ref/default *db-local-sync* run-id #f))
           ;; (if (> (- start-time last-write) 5) ;; every five seconds
           (begin ;; let ((sync-time (- (current-seconds) start-time)))
             (db:multi-db-sync (list run-id) 'new2old)
             (let ((sync-time (- (current-seconds) start-time)))
               (debug:print-info 3 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")
               (if (common:low-noise-print 30 "sync new to old")
                   (debug:print-info 0 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")))
             (hash-table-delete! *db-local-sync* run-id)))
       (mutex-unlock! *db-multi-sync-mutex*))
     run-ids-to-process)))




(define (std-exit-procedure)
  (let ((no-hurry  (if *time-to-exit* ;; hurry up
		       #f
		       (begin
			 (set! *time-to-exit* #t)
			 #t))))

Modified dashboard.scm from [1d05b40be7] to [7a7a0a4eca].

51
52
53
54
55
56
57

58
59
60
61
62
63
64
  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2012-2016

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







>







51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2012-2016

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

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

;;   -server host:port     : connect to host:port instead of db access
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
			) 
		 (list  "-h"
			"-use-server"
			"-guimonitor"
			"-main"
			"-v"
			"-q"
			"-use-local"
			"-skip-version-check"
			)
		 args:arg-hash
		 0))

(if (args:get-arg "-h")
    (begin







|







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"
			)
		 args:arg-hash
		 0))

(if (args:get-arg "-h")
    (begin
241
242
243
244
245
246
247

248
249
250
251
252
253
254
  ((searchpatts        (make-hash-table)) : hash-table)  ;;
  ((state-ignore-hash  (make-hash-table)) : hash-table)  ;; hash of  STATE => #t/#f for display control
  ((status-ignore-hash (make-hash-table)) : hash-table)  ;; hash of STATUS => #t/#f
  (target              #f)
  (test-patts          #f)

  ;; db info to file the .db files for the area

  (dbdir               #f)
  (dbfpath             #f)
  (dbkeys              #f)
  ((last-db-update     (make-hash-table)) : hash-table) ;; last db file timestamp
  (monitor-db-path     #f)                              ;; where to find monitor.db
  ro                                                    ;; is the database read-only?








>







242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
  ((searchpatts        (make-hash-table)) : hash-table)  ;;
  ((state-ignore-hash  (make-hash-table)) : hash-table)  ;; hash of  STATE => #t/#f for display control
  ((status-ignore-hash (make-hash-table)) : hash-table)  ;; hash of STATUS => #t/#f
  (target              #f)
  (test-patts          #f)

  ;; db info to file the .db files for the area
  (access-mode        (db:get-access-mode))             ;; use cached db or not
  (dbdir               #f)
  (dbfpath             #f)
  (dbkeys              #f)
  ((last-db-update     (make-hash-table)) : hash-table) ;; last db file timestamp
  (monitor-db-path     #f)                              ;; where to find monitor.db
  ro                                                    ;; is the database read-only?

296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
  (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
  (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path 0))
  (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))

  ;; HACK ALERT: this is a hack, please fix.
  (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
  
  (dboard:tabdat-keys-set! tabdat (rmt:get-keys))
  (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
  (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%"))
  )

;; RADT => Matrix defstruct addition
(defstruct dboard:graph-dat
    ((id           #f) : string)







|







298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
  (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
  (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path 0))
  (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))

  ;; HACK ALERT: this is a hack, please fix.
  (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
  
  (dboard:tabdat-keys-set! tabdat (db:dispatch-query (db:get-access-mode) rmt:get-keys db:get-keys))
  (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
  (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%"))
  )

;; RADT => Matrix defstruct addition
(defstruct dboard:graph-dat
    ((id           #f) : string)
471
472
473
474
475
476
477

478
479
480
481
482
483
484
485
;; This is roughly the same as dboard:get-tests-dat, should merge them if possible
;;
;; gets all the tests for run-id that match testnamepatt and key-vals, merges them
;;
;;    NOTE: Yes, this is used
;;
(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)

  (let* ((num-to-get
          (let ((num-tests-from-config (configf:lookup *configdat* "setup" "num-tests-to-get")))
            (if num-tests-from-config
                (begin
                  (BB> "override num-tests 100 -> "num-tests-from-config)
                  (string->number num-tests-from-config))
                100)))
	 (states      (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))







>
|







473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
;; This is roughly the same as dboard:get-tests-dat, should merge them if possible
;;
;; gets all the tests for run-id that match testnamepatt and key-vals, merges them
;;
;;    NOTE: Yes, this is used
;;
(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)
  (let* ((access-mode  (dboard:tabdat-access-mode tabdat))
         (num-to-get
          (let ((num-tests-from-config (configf:lookup *configdat* "setup" "num-tests-to-get")))
            (if num-tests-from-config
                (begin
                  (BB> "override num-tests 100 -> "num-tests-from-config)
                  (string->number num-tests-from-config))
                100)))
	 (states      (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))
508
509
510
511
512
513
514

515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
	 (db-path     (or (dboard:rundat-db-path run-dat)
			  (let* ((db-dir (tasks:get-task-db-path))
				 (db-pth (conc db-dir "/" run-id ".db")))
			    (dboard:rundat-db-path-set! run-dat db-pth)
			    db-pth)))
	 (tmptests    (if (or do-not-use-db-file-timestamps
			      (>=  (common:lazy-modification-time db-path) last-update))

                          (rmt:get-tests-for-run run-id testnamepatt states statuses  ;; run-id testpatt states statuses
						 (dboard:rundat-run-data-offset run-dat)
						 num-to-get
						 (dboard:tabdat-hide-not-hide tabdat) ;; no-in
						 sort-by                              ;; sort-by
						 sort-order                           ;; sort-order
						 #f ;; 'shortlist                           ;; qrytype
						 (if (dboard:tabdat-filters-changed tabdat) 
						     0
						     last-update) ;; last-update
						 *dashboard-mode*) ;; use dashboard mode
			  '()))
	 (use-new    (dboard:tabdat-hide-not-hide tabdat))
	 (tests-ht   (if (dboard:tabdat-filters-changed tabdat)
			 (let ((ht (make-hash-table)))
			   (dboard:rundat-tests-set! run-dat ht)
			   ht)
			 (dboard:rundat-tests run-dat)))







>
|
|
|
|
|
|
|
|
|
|
|







511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
	 (db-path     (or (dboard:rundat-db-path run-dat)
			  (let* ((db-dir (tasks:get-task-db-path))
				 (db-pth (conc db-dir "/" run-id ".db")))
			    (dboard:rundat-db-path-set! run-dat db-pth)
			    db-pth)))
	 (tmptests    (if (or do-not-use-db-file-timestamps
			      (>=  (common:lazy-modification-time db-path) last-update))
                          (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
                                             run-id testnamepatt states statuses  ;; run-id testpatt states statuses
                                             (dboard:rundat-run-data-offset run-dat)
                                             num-to-get
                                             (dboard:tabdat-hide-not-hide tabdat) ;; no-in
                                             sort-by                              ;; sort-by
                                             sort-order                           ;; sort-order
                                             #f ;; 'shortlist                           ;; qrytype
                                             (if (dboard:tabdat-filters-changed tabdat) 
                                                 0
                                                 last-update) ;; last-update
                                             *dashboard-mode*) ;; use dashboard mode
			  '()))
	 (use-new    (dboard:tabdat-hide-not-hide tabdat))
	 (tests-ht   (if (dboard:tabdat-filters-changed tabdat)
			 (let ((ht (make-hash-table)))
			   (dboard:rundat-tests-set! run-dat ht)
			   ht)
			 (dboard:rundat-tests run-dat)))
584
585
586
587
588
589
590

591
592

593
594

595
596
597
598
599
600
601
602

;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts)

  (let* ((keys             (rmt:get-keys))
	 (last-runs-update (dboard:tabdat-last-runs-update tabdat))

         (allruns          (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
         ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))

         (allruns-tree    (rmt:get-runs-by-patt 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))







>
|

>
|

>
|







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

;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
  (let* ((access-mode      (dboard:tabdat-access-mode tabdat))
         (keys             (db:dispatch-query access-mode rmt:get-keys db:get-keys))
	 (last-runs-update (dboard:tabdat-last-runs-update tabdat))
         (allruns          (db:dispatch-query access-mode rmt:get-runs db:get-runs
                                              runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
         ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
         (allruns-tree    (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt
                                             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))
1462
1463
1464
1465
1466
1467
1468

1469

1470
1471
1472
1473
1474
1475
1476

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

(define (dboard:get-tests-dat tabdat run-id last-update)

  (let* ((tdat (if run-id (rmt:get-tests-for-run run-id 

					     (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
					     (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))  ;; '()
					     (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '()
					     #f #f                                                       ;; offset limit
					     (dboard:tabdat-hide-not-hide tabdat)                        ;; not-in
					     #f #f                                                       ;; sort-by sort-order
					     #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration"                        ;; qryval







>
|
>







1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485

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

(define (dboard:get-tests-dat tabdat run-id last-update)
  (let* ((access-mode     (dboard:tabdat-access-mode tabdat))
         (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
                                             run-id 
					     (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
					     (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))  ;; '()
					     (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '()
					     #f #f                                                       ;; offset limit
					     (dboard:tabdat-hide-not-hide tabdat)                        ;; not-in
					     #f #f                                                       ;; sort-by sort-order
					     #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration"                        ;; qryval
1493
1494
1495
1496
1497
1498
1499

1500
1501
1502
1503
1504
1505
1506
1507
1508

1509
1510
1511
1512
1513
1514
1515
1516
(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* ((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     (rmt:get-runs-by-patt (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))







>
|








>
|







1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
(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:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt
                                          (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))
1570
1571
1572
1573
1574
1575
1576

1577

1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593


1594
1595
1596
1597
1598
1599
1600
1601
         (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash)
         (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash)
         hide-clean: hide-clean)
        #f)))


(define (dashboard:get-runs-hash tabdat)

  (let* ((last-runs-update  0);;(dboard:tabdat-last-runs-update tabdat))

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

(define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)
  (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat)
      (dashboard:do-update-rundat tabdat))
  (dboard:runs-summary-control-panel-updater tabdat)
  (let* ((last-runs-update  (dboard:tabdat-last-runs-update tabdat))


	 (runs-dat     (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
         (runs         (vector-ref runs-dat 1))
	 (run-id       (dboard:tabdat-curr-run-id tabdat))
         (runs-hash (dashboard:get-runs-hash tabdat))
         ;; (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))







>
|
>
|















>
>
|







1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
         (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash)
         (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash)
         hide-clean: hide-clean)
        #f)))


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

(define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)
  (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat)
      (dashboard:do-update-rundat tabdat))
  (dboard:runs-summary-control-panel-updater tabdat)
  (let* ((last-runs-update  (dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (db:dispatch-query (dboard:tabdat-access-mode tabdat)
                                          rmt:get-runs-by-patt db:get-runs-by-patt
                                          (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
         (runs         (vector-ref runs-dat 1))
	 (run-id       (dboard:tabdat-curr-run-id tabdat))
         (runs-hash (dashboard:get-runs-hash tabdat))
         ;; (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))
2698
2699
2700
2701
2702
2703
2704

2705


2706
2707
2708
2709
2710
2711
2712
2713
	      (lambda (a b)
		(< (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* ((last-runs-update (dboard:tabdat-last-runs-update tabdat))


         (runs-dat      (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header   (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
	 (runs-hash     (let ((ht (make-hash-table)))
			  (for-each (lambda (run)
				      (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
				    (vector-ref runs-dat 1))
			  ht))
	 (run-ids       (sort (filter number? (hash-table-keys runs-hash))







>
|
>
>
|







2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
	      (lambda (a b)
		(< (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))
         (runs-dat      (db:dispatch-query access-mode
                                           rmt:get-runs-by-patt db:get-runs-by-patt
                                           (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header   (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
	 (runs-hash     (let ((ht (make-hash-table)))
			  (for-each (lambda (run)
				      (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
				    (vector-ref runs-dat 1))
			  ht))
	 (run-ids       (sort (filter number? (hash-table-keys runs-hash))

Modified db.scm from [1b7107e1c1] to [843bf5a690].

798
799
800
801
802
803
804










805
806
807

808
809
810
811
812
813
814
                               BEGIN 
                                 UPDATE run_stats SET last_update=(strftime('%s','now'))
                                   WHERE id=old.id;
                               END;"))

(define *global-db-store* (make-hash-table))











;; return the target db handle so it can be used
;;
(define (db:cache-for-read-only source target #!key (use-last-update #f))

  (if (and (hash-table-ref/default *global-db-store* target #f)
	   (>= (file-modification-time target)(file-modification-time source)))
      (hash-table-ref *global-db-store* target)
      (let* ((toppath   (launch:setup))
	     (targ-db-last-mod (if (file-exists? target)
				   (file-modification-time target)
				   0))







>
>
>
>
>
>
>
>
>
>



>







798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
                               BEGIN 
                                 UPDATE run_stats SET last_update=(strftime('%s','now'))
                                   WHERE id=old.id;
                               END;"))

(define *global-db-store* (make-hash-table))

(define (db:get-access-mode)
  (if (args:get-arg "-use-db-cache") 'cached 'rmt))

;; Add db direct
;;
(define (db:dispatch-query access-mode rmt-cmd db-cmd . params)
  (if (eq? access-mode 'cached)
      (apply db:call-with-cached-db db-cmd params)
      (apply rmt-cmd params)))

;; return the target db handle so it can be used
;;
(define (db:cache-for-read-only source target #!key (use-last-update #f))
  (common:sync-to-megatest.db #t) ;; BUG!! DON'T LEAVE THIS HERE!
  (if (and (hash-table-ref/default *global-db-store* target #f)
	   (>= (file-modification-time target)(file-modification-time source)))
      (hash-table-ref *global-db-store* target)
      (let* ((toppath   (launch:setup))
	     (targ-db-last-mod (if (file-exists? target)
				   (file-modification-time target)
				   0))
849
850
851
852
853
854
855

856
857
858
859
860
861
862
;;
;;  'killservers  - kills all servers
;;  'dejunk       - removes junk records
;;  'adj-testids  - move test-ids into correct ranges
;;  'old2new      - sync megatest.db records to .db/{main,1,2 ...}.db
;;  'new2old      - sync .db/{main,1,2,3 ...}.db to megatest.db
;;  'closeall     - close all opened dbs

;;
;;  run-ids: '(1 2 3 ...) or #f (for all)
;;
(define (db:multi-db-sync run-ids . options)
  (let* ((toppath  (launch:setup))
	 (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f))
	 (mtdb     (if toppath (db:open-megatest-db)))







>







860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
;;
;;  'killservers  - kills all servers
;;  'dejunk       - removes junk records
;;  'adj-testids  - move test-ids into correct ranges
;;  'old2new      - sync megatest.db records to .db/{main,1,2 ...}.db
;;  'new2old      - sync .db/{main,1,2,3 ...}.db to megatest.db
;;  'closeall     - close all opened dbs
;;  'schema       - attempt to apply schema changes
;;
;;  run-ids: '(1 2 3 ...) or #f (for all)
;;
(define (db:multi-db-sync run-ids . options)
  (let* ((toppath  (launch:setup))
	 (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f))
	 (mtdb     (if toppath (db:open-megatest-db)))
923
924
925
926
927
928
929

930
931
932
933
934
935
936
937
938
939
940
           (map
            (lambda (run-id)
              (thread-start! 
               (make-thread
                (lambda ()
                  (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))
                         (frundb (db:dbdat-get-db (db:get-db fromdb run-id))))

                    (if (eq? run-id 0)
                        (let ((maindb  (db:dbdat-get-db (db:get-db fromdb #f))))
                          (db:patch-schema-maindb run-id maindb))
                        (db:patch-schema-rundb run-id frundb)))
                  (set! count (+ count 1))
                  (debug:print 0 *default-log-port* "Finished patching schema for " (if (eq? run-id 0) " main.db " (conc run-id ".db")) ", " count " of " total)))))
            all-run-ids))
          ;; Then sync and fix db's
          (set! count 0)
          (process-fork
           (lambda ()







>
|
|
|
|







935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
           (map
            (lambda (run-id)
              (thread-start! 
               (make-thread
                (lambda ()
                  (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))
                         (frundb (db:dbdat-get-db (db:get-db fromdb run-id))))
                    (if (member 'schema options)
                        (if (eq? run-id 0)
                            (let ((maindb  (db:dbdat-get-db (db:get-db fromdb #f))))
                              (db:patch-schema-maindb run-id maindb))
                            (db:patch-schema-rundb run-id frundb))))
                  (set! count (+ count 1))
                  (debug:print 0 *default-log-port* "Finished patching schema for " (if (eq? run-id 0) " main.db " (conc run-id ".db")) ", " count " of " total)))))
            all-run-ids))
          ;; Then sync and fix db's
          (set! count 0)
          (process-fork
           (lambda ()

Modified megatest.scm from [81d6e15344] to [a1a4b74e6e].

353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
     (let ((legacy-sync (common:legacy-sync-required))
	   (debug-mode  (debug:debug-mode 1))
	   (last-time   (current-seconds)))
       (if (common:legacy-sync-recommended)
	   (let loop ()
	     ;; sync for filesystem local db writes
	     ;;
	     (let ((start-time      (current-seconds))
		   (servers-started (make-hash-table)))
	       (for-each 
		(lambda (run-id)
		  (mutex-lock! *db-multi-sync-mutex*)
		  (if (and legacy-sync 
			   (hash-table-ref/default *db-local-sync* run-id #f))
		      ;; (if (> (- start-time last-write) 5) ;; every five seconds
		      (begin ;; let ((sync-time (- (current-seconds) start-time)))
			(db:multi-db-sync (list run-id) 'new2old)
			(let ((sync-time (- (current-seconds) start-time)))
			  (debug:print-info 3 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")
			  (if (common:low-noise-print 30 "sync new to old")
			      (debug:print-info 0 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")))
			;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run
			;;     (begin
			;;       (debug:print-info 0 *default-log-port* "Sync is taking a long time, start up a server to assist for run " run-id)
			;;       (server:kind-run run-id)))))
			(hash-table-delete! *db-local-sync* run-id)))
		  (mutex-unlock! *db-multi-sync-mutex*))
		(hash-table-keys *db-local-sync*))
	       (if (and debug-mode
			(> (- start-time last-time) 60))
		   (begin
		     (set! last-time start-time)
		     (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
	     
	     ;; keep going unless time to exit







|
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







353
354
355
356
357
358
359
360




361















362
363
364
365
366
367
368
     (let ((legacy-sync (common:legacy-sync-required))
	   (debug-mode  (debug:debug-mode 1))
	   (last-time   (current-seconds)))
       (if (common:legacy-sync-recommended)
	   (let loop ()
	     ;; sync for filesystem local db writes
	     ;;
             (let ((start-time   (current-seconds)))




               (if legacy-sync (common:sync-to-megatest.db #f))















	       (if (and debug-mode
			(> (- start-time last-time) 60))
		   (begin
		     (set! last-time start-time)
		     (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
	     
	     ;; keep going unless time to exit
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
  (let ((indx (hash-table-ref/default test-field-index fieldname #f)))
    (if indx
	(if (>= indx (vector-length datavec))
	    #f ;; index too high, should raise an error I suppose
	    (vector-ref datavec indx))
	#f)))

;; Add db direct
;;
(define (dispatch-query access-mode rmt-cmd db-cmd . params)
  (if (eq? access-mode 'cached)
      (apply db:call-with-cached-db db-cmd params)
      (apply rmt-cmd params)))

;; NOTE: list-runs and list-db-targets operate on local db!!!
;;
;; IDEA: megatest list -runname blah% ...
;;
(if (or (args:get-arg "-list-runs")
	(args:get-arg "-list-db-targets"))
    (if (launch:setup)
	(let* (;; (dbstruct    (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local")))
	       (runpatt     (args:get-arg "-list-runs"))
               (access-mode (if (args:get-arg "-use-db-cache") 'cached 'rmt))
	       (testpatt    (common:args-get-testpatt #f))
	       ;; (if (args:get-arg "-testpatt") 
	       ;;  	        (args:get-arg "-testpatt") 
	       ;;  	        "%"))
	       (keys        (rmt:get-keys)) ;; (db:get-keys dbstruct))
	       ;; (runsdat  (db:get-runs dbstruct runpatt #f #f '()))
	;; (runsdat     (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
	;; 		           	 #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
	       (runsdat     (dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt keys (or runpatt "%") 
                                            (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
	       (runstmp     (db:get-rows runsdat))
	       (header      (db:get-header runsdat))
	       ;; this is "-since" support. This looks at last mod times of <run-id>.db files
	       ;; and collects those modified since the -since time.
	       (runs        (if (and (not (null? runstmp))
				     (args:get-arg "-since"))







<
<
<
<
<
<
<









|








|







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
  (let ((indx (hash-table-ref/default test-field-index fieldname #f)))
    (if indx
	(if (>= indx (vector-length datavec))
	    #f ;; index too high, should raise an error I suppose
	    (vector-ref datavec indx))
	#f)))








;; NOTE: list-runs and list-db-targets operate on local db!!!
;;
;; IDEA: megatest list -runname blah% ...
;;
(if (or (args:get-arg "-list-runs")
	(args:get-arg "-list-db-targets"))
    (if (launch:setup)
	(let* (;; (dbstruct    (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local")))
	       (runpatt     (args:get-arg "-list-runs"))
               (access-mode (db:get-access-mode))
	       (testpatt    (common:args-get-testpatt #f))
	       ;; (if (args:get-arg "-testpatt") 
	       ;;  	        (args:get-arg "-testpatt") 
	       ;;  	        "%"))
	       (keys        (rmt:get-keys)) ;; (db:get-keys dbstruct))
	       ;; (runsdat  (db:get-runs dbstruct runpatt #f #f '()))
	;; (runsdat     (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
	;; 		           	 #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
	       (runsdat     (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt keys (or runpatt "%") 
                                            (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
	       (runstmp     (db:get-rows runsdat))
	       (header      (db:get-header runsdat))
	       ;; this is "-since" support. This looks at last mod times of <run-id>.db files
	       ;; and collects those modified since the -since time.
	       (runs        (if (and (not (null? runstmp))
				     (args:get-arg "-since"))
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
			     (hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '())))
			     )))
		   (let* ((run-id  (db:get-value-by-header run header "id"))
			  (runname (db:get-value-by-header run header "runname")) 
			  (states  (string-split (or (args:get-arg "-state") "") ","))
			  (statuses (string-split (or (args:get-arg "-status") "") ","))
			  (tests   (if tests-spec
				       (dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc 
							     ;; use qryvals if test-spec provided
							     (if tests-spec
								 (string-intersperse adj-tests-spec ",")
								 ;; db:test-record-fields
								 #f)
							     #f
							     'normal)







|







1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
			     (hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '())))
			     )))
		   (let* ((run-id  (db:get-value-by-header run header "id"))
			  (runname (db:get-value-by-header run header "runname")) 
			  (states  (string-split (or (args:get-arg "-state") "") ","))
			  (statuses (string-split (or (args:get-arg "-status") "") ","))
			  (tests   (if tests-spec
				       (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc 
							     ;; use qryvals if test-spec provided
							     (if tests-spec
								 (string-intersperse adj-tests-spec ",")
								 ;; db:test-record-fields
								 #f)
							     #f
							     'normal)
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
						 (conc "\n         rundir:   " (get-value-by-fieldname test test-field-index "rundir")) ;; (db:test-get-rundir test)
						 "")
;;					     "\n         rundir:   " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* 
;; 					     (db:test-get-rundir test) ;; )
					     )
				    ;; Each test
				    ;; DO NOT remote run
				    (let ((steps (dispatch-query access-mode rmt:get-steps-for-test db:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test))))
				      (for-each 
				       (lambda (step)
					 (format #t 
						 "    Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
						 (tdb:step-get-stepname step)
						 (tdb:step-get-state step)
						 (tdb:step-get-status step)







|







1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
						 (conc "\n         rundir:   " (get-value-by-fieldname test test-field-index "rundir")) ;; (db:test-get-rundir test)
						 "")
;;					     "\n         rundir:   " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* 
;; 					     (db:test-get-rundir test) ;; )
					     )
				    ;; Each test
				    ;; DO NOT remote run
				    (let ((steps (db:dispatch-query access-mode rmt:get-steps-for-test db:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test))))
				      (for-each 
				       (lambda (step)
					 (format #t 
						 "    Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
						 (tdb:step-get-stepname step)
						 (tdb:step-get-state step)
						 (tdb:step-get-status step)