1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
|
-
+
-
+
-
-
+
-
-
-
-
+
-
-
-
-
+
+
-
+
-
-
-
+
+
+
+
+
+
+
|
;;======================================================================
;; Copyright 2006-2013, Matthew Welland.
;; Copyright 2006-2016, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; This file is part of Megatest.
;; greater. See the accompanying file COPYING for details.
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; Megatest is free software: you can redistribute it and/or modify
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
;;======================================================================
;; Copyright 2006-2016, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(use format)
(use (prefix iup iup:))
(use canvas-draw)
|
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
|
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
|
-
+
|
(if (args:get-arg "-h")
(begin
(print help)
(exit)))
;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
(if (file-exists? debugcontrolf)
(if (common:file-exists? debugcontrolf)
(load debugcontrolf)))
(debug:setup)
(define *tim* (iup:timer))
(define *ord* #f)
|
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
|
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
|
-
+
|
(if (not (null? path))
(hash-table-ref/default (dboard:data-path-test-ids *data*) path #f)
#f))
(define (test-panel window-id)
(let* ((curr-row-num 0)
(viewlog (lambda (x)
(if (file-exists? logfile)
(if (common:file-exists? logfile)
;(system (conc "firefox " logfile "&"))
(iup:send-url logfile)
(message-window (conc "File " logfile " not found")))))
(xterm (lambda (x)
(if (directory-exists? rundir)
(let ((shell (if (get-environment-variable "SHELL")
(conc "-e " (get-environment-variable "SHELL"))
|
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
|
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
|
-
+
-
+
+
|
(iup:callback-set! *tim*
"ACTION_CB"
(lambda (x)
;; Want to dedicate no more than 50% of the time to this so skip if
;; 2x delta time has not passed since last query
(if (< nextmintime (current-milliseconds))
(let* ((starttime (current-milliseconds))
(changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
;; (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
(endtime (current-milliseconds)))
(set! nextmintime (+ endtime (* 2 (- endtime starttime))))
(debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
;; (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
)
(debug:print-info 11 *default-log-port* "Server overloaded"))))))
;; (dboard:data-updaters-set! *data* (make-hash-table))
(newdashboard #f) ;; *dbstruct-local*)
(iup:main-loop)
|