| ︙ | | | ︙ | |
37
38
39
40
41
42
43
44
45
46
47
48
49
50
|
;; (declare (uses dashboard-main))
(declare (uses megatest-version))
(declare (uses mt))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright (C) Matt Welland 2013
Usage: dashboard [options]
|
>
|
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
|
;; (declare (uses dashboard-main))
(declare (uses megatest-version))
(declare (uses mt))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "megatest-fossil-hash.scm")
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright (C) Matt Welland 2013
Usage: dashboard [options]
|
| ︙ | | | ︙ | |
61
62
63
64
65
66
67
68
69
70
71
72
73
74
|
(define remargs (args:get-args
(argv)
(list "-rows"
"-run"
"-test"
"-debug"
"-host"
)
(list "-h"
"-use-server"
"-guimonitor"
"-main"
"-v"
"-q"
|
>
|
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
|
(define remargs (args:get-args
(argv)
(list "-rows"
"-run"
"-test"
"-debug"
"-host"
"-transport"
)
(list "-h"
"-use-server"
"-guimonitor"
"-main"
"-v"
"-q"
|
| ︙ | | | ︙ | |
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
(define *db* #f) ;; (open-db))
(if (args:get-arg "-host")
(begin
(set! *runremote* (string-split (args:get-arg "-host" ":")))
(client:launch))
(if (not (args:get-arg "-use-server"))
(set! *transport-type* 'fs) ;; force fs access
(client:launch)))
;; HACK ALERT: this is a hack, please fix.
(define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db"))))
;; (client:setup *db*)
(define toplevel #f)
|
|
>
|
>
|
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
(define *db* #f) ;; (open-db))
(if (args:get-arg "-host")
(begin
(set! *runremote* (string-split (args:get-arg "-host" ":")))
(client:launch))
(if (args:get-arg "-transport")
(begin
(set! *transport-type* (string->symbol (args:get-arg "-transport"))) ;; force fs access
(client:launch))
(client:launch)))
;; HACK ALERT: this is a hack, please fix.
(define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db"))))
;; (client:setup *db*)
(define toplevel #f)
|
| ︙ | | | ︙ | |
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
(define *buttondat* (make-hash-table)) ;; <run-id color text test run-key>
(define *alltestnamelst* '())
(define *searchpatts* (make-hash-table))
(define *num-runs* 8)
(define *tot-run-count* (cdb:remote-run db:get-num-runs #f "%"))
;; (define *tot-run-count* (db:get-num-runs *db* "%"))
(define *last-update* (current-seconds))
(define *last-db-update-time* 0)
(define *please-update-buttons* #t)
(define *delayed-update* 0)
(define *num-tests* 15)
(define *start-run-offset* 0)
(define *start-test-offset* 0)
(define *examine-test-dat* (make-hash-table))
(define *exit-started* #f)
(define *status-ignore-hash* (make-hash-table))
|
>
>
>
>
>
|
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
(define *buttondat* (make-hash-table)) ;; <run-id color text test run-key>
(define *alltestnamelst* '())
(define *searchpatts* (make-hash-table))
(define *num-runs* 8)
(define *tot-run-count* (cdb:remote-run db:get-num-runs #f "%"))
;; (define *tot-run-count* (db:get-num-runs *db* "%"))
;; Update management
;;
(define *last-update* (current-seconds))
(define *last-db-update-time* 0)
(define *please-update-buttons* #t)
(define *delayed-update* 0)
(define *update-is-running* #f)
(define *update-mutex* (make-mutex))
(define *num-tests* 15)
(define *start-run-offset* 0)
(define *start-test-offset* 0)
(define *examine-test-dat* (make-hash-table))
(define *exit-started* #f)
(define *status-ignore-hash* (make-hash-table))
|
| ︙ | | | ︙ | |
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
|
(set! *last-db-update-time* modtime)
(set! *last-update* run-update-time)))))
;;======================================================================
;; The heavy lifting starts here
;;======================================================================
;; ease debugging by loading ~/.megatestrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
(cond
((args:get-arg "-run")
(let ((runid (string->number (args:get-arg "-run"))))
(if runid
|
|
|
|
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
|
(set! *last-db-update-time* modtime)
(set! *last-update* run-update-time)))))
;;======================================================================
;; The heavy lifting starts here
;;======================================================================
;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
(cond
((args:get-arg "-run")
(let ((runid (string->number (args:get-arg "-run"))))
(if runid
|
| ︙ | | | ︙ | |
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
|
((args:get-arg "-guimonitor")
(gui-monitor *db*))
(else
(set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*))
(iup:callback-set! *tim*
"ACTION_CB"
(lambda (x)
(dashboard:run-update x)
1))))
(iup:main-loop)
|
>
>
>
>
>
>
>
>
|
>
>
>
|
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
|
((args:get-arg "-guimonitor")
(gui-monitor *db*))
(else
(set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*))
(iup:callback-set! *tim*
"ACTION_CB"
(lambda (x)
(let ((update-is-running #f))
(mutex-lock! *update-mutex*)
(set! update-is-running *update-is-running*)
(if (not update-is-running)
(set! *update-is-running* #t))
(mutex-unlock! *update-mutex*)
(if (not update-is-running)
(begin
(dashboard:run-update x)
(mutex-lock! *update-mutex*)
(set! *update-is-running* #f)
(mutex-unlock! *update-mutex*))))
1))))
(iup:main-loop)
|