| ︙ | | |
37
38
39
40
41
42
43
44
45
46
47
48
49
50
|
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
|
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
|
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 (not (args:get-arg "-use-server"))
(set! *transport-type* 'fs) ;; force fs access
(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
|
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))
|
| ︙ | | |
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
|
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
|
+
+
-
+
|
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")
;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
;;
(define *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db")))
(define *last-recalc-ended-time* 0)
(define (dashboard:been-changed)
(> (file-modification-time (conc *toppath* "/megatest.db")) *last-db-update-time*))
(define (dashboard:set-db-update-time)
(set! *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db"))))
(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
(or please-update-buttons
(and (> (current-milliseconds)(+ *last-recalc-ended-time* 150))
(and (> modtime last-db-update-time)
|
| ︙ | | |
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
|
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
|
-
+
+
-
-
+
+
|
((2)
(dashboard:update-run-summary-tab))
(else
(let ((updater (hash-table-ref/default *updaters* *current-tab-number* #f)))
(if updater (updater)))))
(set! *please-update-buttons* #f)
(set! *last-db-update-time* modtime)
(set! *last-update* run-update-time)))))
(set! *last-update* run-update-time)
(set! *last-recalc-ended-time* (current-milliseconds))))))
;;======================================================================
;; The heavy lifting starts here
;;======================================================================
;; ease debugging by loading ~/.megatestrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
;; 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
|
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
|
+
+
+
+
+
+
+
+
-
+
+
+
+
|
((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)
(dashboard:run-update x)
(mutex-lock! *update-mutex*)
(set! *update-is-running* #f)
(mutex-unlock! *update-mutex*))))
1))))
(iup:main-loop)
|