Megatest

Check-in [77cd1aff88]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:More clean up. Added missing import of imports in megatest.scm and dashboard.scm.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.65-try3
Files: files | file ages | folders
SHA1: 77cd1aff880b9ae014d9495bfc358095c1007049
User & Date: mrwellan on 2019-12-06 16:03:58
Other Links: branch diff | manifest | tags
Context
2019-12-07
19:57
clean-up check-in: 9ab2add492 user: matt tags: v1.65-try3
2019-12-06
16:03
More clean up. Added missing import of imports in megatest.scm and dashboard.scm. check-in: 77cd1aff88 user: mrwellan tags: v1.65-try3
04:50
Clean up check-in: a7636bcfcc user: matt tags: v1.65-try3
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified NOTES from [77a2fe6f9e] to [e117eafbc6].

︙
156
157
158
159
160
161
162





156
157
158
159
160
161
162
163
164
165
166








+
+
+
+

INFO: (0) Number non-cached queries 74289
INFO: (0) Average non-cached time   1055.09826488444 ms
INFO: (0) Server shutdown complete. Exiting

Start: 0 at Sun Apr 28 22:18:25 MST 2013
Max:  52 at Sun Apr 28 23:06:59 MST 2013
End:   6 at Sun Apr 28 23:47:51 MST 2013


## Binary size, Dec 6, 2019
v1.65-try3 11744824 Dec  6 10:08 bin/.11/mtest

Name change from tree.scm to attic/tree.scm.

︙

Name change from vg-test.scm to attic/vg-test.scm.

︙

Name change from widgets.scm to attic/widgets.scm.

︙

Modified common_records.scm from [ca85e255b3] to [6eee551227].

︙
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33

18
19
20
21
22
23
24


25
26
27
28
29
30
31








-
-








;;
;;======================================================================

;; (use trace)
(use typed-records)

;; globals - modules that include this need these here
(define *verbosity-cache* (make-hash-table))
(define *verbosity* 0)
(define *default-log-port* (current-error-port))
(define *logging* #f)
(define *functions* (make-hash-table)) ;; symbol => fn ### TEMPORARY!!!
;; (define *toppath* #f)
(define *transport-type* 'http)

#;(define (exec-fn fn . params)
︙
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
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364

282
283
284
285
286
287
288



































































289
290
291
292
293
294
295








-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-








;;
(define-inline (with-mutex mtx accessor record . val)
  (mutex-lock! mtx)
  (let ((res (apply accessor record val)))
    (mutex-unlock! mtx)
    res))

;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
(define (debug:calc-verbosity vstr verbose quiet) ;; verbose and quiet are #f or enabled
  (or (hash-table-ref/default *verbosity-cache* vstr #f)
      (let ((res (cond
                  ((number? vstr) vstr)
                  ((not (string?  vstr))   1)
                  ;; ((string-match  "^\\s*$" vstr) 1)
                  (vstr           (let ((debugvals  (filter number? (map string->number (string-split vstr ",")))))
                                    (cond
                                     ((> (length debugvals) 1) debugvals)
                                     ((> (length debugvals) 0)(car debugvals))
                                     (else 1))))
                  (verbose                2) ;; ((args:get-arg "-v")   2)
                  (quiet                  0) ;; ((args:get-arg "-q")    0)
                  (else                   1))))
        (hash-table-set! *verbosity-cache* vstr res)
        res)))

;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
  (if (not (or (number? verbosity)
	       (list?   verbosity)))
      (begin
	(print "ERROR: Invalid debug value \"" vstr "\"")
	#f)
      #t))

(define (debug:debug-mode n)
  (cond
   ((and (number? *verbosity*)   ;; number number
	 (number? n))
    (<= n *verbosity*))
   ((and (list? *verbosity*)     ;; list   number
	 (number? n))
    (member n *verbosity*))
   ((and (list? *verbosity*)     ;; list   list
	 (list? n))
    (not (null? (lset-intersection! eq? *verbosity* n))))
   ((and (number? *verbosity*)
	 (list? n))
    (member *verbosity* n))))

(define (debug:setup dmode verbose quiet)
  (let ((debugstr (or dmode                           ;; (args:get-arg "-debug")
		      (get-environment-variable "MT_DEBUG_MODE"))))
    (set! *verbosity* (debug:calc-verbosity debugstr verbose quiet))
    (debug:check-verbosity *verbosity* debugstr)
    ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
    (if (not *verbosity*)(set! *verbosity* 1))
    (if (or dmode                                            ;; (args:get-arg "-debug")
	    (not (get-environment-variable "MT_DEBUG_MODE")))
	(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
				    (string-intersperse (map conc *verbosity*) ",")
				    (conc *verbosity*))))))
  
(define (debug:print n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  ;; (if *logging*
	  ;;    (exec-fn 'db:log-event (apply conc params))
	  (apply print params)
	  )))) ;; )

;; Brandon's debug printer shortcut (indulge me :)
;; (define *BB-process-starttime* (current-milliseconds))
#;(define (BB> . in-args)
  (let* ((stack (get-call-chain))
         (location "??"))
    (for-each
     (lambda (frame)
︙
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461

350
351
352
353
354
355
356





























357
358
359
360
361
362
363








-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-








  (syntax-rules ()
    [(_ x)
    ;; (with-output-to-port (current-error-port)
       (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
     ;;  )
     ]
    [(_ x y ...) (begin (inspect x) (inspect y ...))]))

(define (debug:print-error n e . params)
  ;; normal print
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  ;; (if *logging*
	     ;; (exec-fn 'db:log-event (apply conc params))
	      ;; (apply print "pid:" (current-process-id) " " params)
	  (apply print "ERROR: " params)
	  ))) ;; )
  ;; pass important messages to stderr
  (if (and (eq? n 0)(not (eq? e (current-error-port)))) 
      (with-output-to-port (current-error-port)
	(lambda ()
	  (apply print "ERROR: " params)
	  ))))

(define (debug:print-info n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  ;; (if *logging*
	  ;;    (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
		;; (exec-fn 'db:log-event res))
	      ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
	  (apply print "INFO: (" n ") " params) ;; res)
	  )))) ;; )



;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
  (if (or (number? val)(string? val)) val ""))

Modified commonmod.scm from [1222c68df8] to [1896faeca2].

︙
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

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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148








-
+












-
+





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit commonmod))
(declare (uses processmod))
;; (declare (uses processmod))

(module commonmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18
	srfi-1 files format srfi-13 matchable 
	srfi-69 ports
	regex-case regex hostinfo srfi-4
	pkts (prefix dbi dbi:)
	stack)

(import processmod)
;; (import processmod)
(import stml2)

(include "common_records.scm")
(include "megatest-fossil-hash.scm")
(include "megatest-version.scm")

 ;; no need to export this
(define *verbosity-cache* (make-hash-table))
(define *verbosity* 0)

;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
(define (debug:calc-verbosity vstr verbose quiet) ;; verbose and quiet are #f or enabled
  (or (hash-table-ref/default *verbosity-cache* vstr #f)
      (let ((res (cond
                  ((number? vstr) vstr)
                  ((not (string?  vstr))   1)
                  ;; ((string-match  "^\\s*$" vstr) 1)
                  (vstr           (let ((debugvals  (filter number? (map string->number (string-split vstr ",")))))
                                    (cond
                                     ((> (length debugvals) 1) debugvals)
                                     ((> (length debugvals) 0)(car debugvals))
                                     (else 1))))
                  (verbose                2) ;; ((args:get-arg "-v")   2)
                  (quiet                  0) ;; ((args:get-arg "-q")    0)
                  (else                   1))))
        (hash-table-set! *verbosity-cache* vstr res)
        res)))

;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
  (if (not (or (number? verbosity)
	       (list?   verbosity)))
      (begin
	(print "ERROR: Invalid debug value \"" vstr "\"")
	#f)
      #t))

(define (debug:debug-mode n)
  (cond
   ((and (number? *verbosity*)   ;; number number
	 (number? n))
    (<= n *verbosity*))
   ((and (list? *verbosity*)     ;; list   number
	 (number? n))
    (member n *verbosity*))
   ((and (list? *verbosity*)     ;; list   list
	 (list? n))
    (not (null? (lset-intersection! eq? *verbosity* n))))
   ((and (number? *verbosity*)
	 (list? n))
    (member *verbosity* n))))

(define (debug:setup dmode verbose quiet)
  (let ((debugstr (or dmode                           ;; (args:get-arg "-debug")
		      (get-environment-variable "MT_DEBUG_MODE"))))
    (set! *verbosity* (debug:calc-verbosity debugstr verbose quiet))
    (debug:check-verbosity *verbosity* debugstr)
    ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
    (if (not *verbosity*)(set! *verbosity* 1))
    (if (or dmode                                            ;; (args:get-arg "-debug")
	    (not (get-environment-variable "MT_DEBUG_MODE")))
	(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
				    (string-intersperse (map conc *verbosity*) ",")
				    (conc *verbosity*))))))
  
(define (debug:print n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  ;; (if *logging*
	  ;;    (exec-fn 'db:log-event (apply conc params))
	  (apply print params)
	  )))) ;; )

(define (debug:print-error n e . params)
  ;; normal print
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  ;; (if *logging*
	     ;; (exec-fn 'db:log-event (apply conc params))
	      ;; (apply print "pid:" (current-process-id) " " params)
	  (apply print "ERROR: " params)
	  ))) ;; )
  ;; pass important messages to stderr
  (if (and (eq? n 0)(not (eq? e (current-error-port)))) 
      (with-output-to-port (current-error-port)
	(lambda ()
	  (apply print "ERROR: " params)
	  ))))

(define (debug:print-info n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  ;; (if *logging*
	  ;;    (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
		;; (exec-fn 'db:log-event res))
	      ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
	  (apply print "INFO: (" n ") " params) ;; res)
	  )))) ;; )



;; (define (common:low-noise-print alldat waitval . keys)
;;   (let* ((key      (string-intersperse (map conc keys) "-" ))
;; 	 (lasttime (hash-table-ref/default (alldat-denoise alldat) key 0))
;; 	 (currtime (current-seconds)))
;;     (if (> (- currtime lasttime) waitval)
;; 	(begin
︙

Modified dashboard.scm from [96d2c80da7] to [eb1dd516fd].

︙
67
68
69
70
71
72
73

74
75
76
77
78
79
80

67
68
69
70
71
72
73
74
75
76
77
78
79
80
81








+








(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")

;; invoke the imports
(declare (uses commonmod.import))
(declare (uses megamod.import))
(declare (uses dcommonmod.import))

(configf:set-debug-printers debug:print debug:print-info debug:print-error *default-log-port*)
(configf:add-eval-string "(import megamod)")
︙

Modified dcommonmod.scm from [ed2046f80e] to [5fdbbc15ad].

︙
15
16
17
18
19
20
21
22

23
24
25
26
27
28
29

15
16
17
18
19
20
21

22
23
24
25
26
27
28
29








-
+








;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit dcommonmod))
;; (declare (uses commonmod))
(declare (uses commonmod))
(declare (uses megamod))

(module dcommonmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:)
︙
77
78
79
80
81
82
83
84

85
86
87
88
89
90
91

77
78
79
80
81
82
83

84
85
86
87
88
89
90
91








-
+








	udp
	uri-common
	z3
	)

(use (prefix mtconfigf configf:))

;; (import commonmod)
(import commonmod)
(import megamod)
(import canvas-draw)
(import canvas-draw-iup)
(use (prefix iup iup:))

(define *tim* (iup:timer))
︙

Modified keysmod.scm from [0eefafb09c] to [834fcec6d9].

︙
15
16
17
18
19
20
21
22

23
24
25
26
27
28

29
30
31
32
33

34
35
36

15
16
17
18
19
20
21

22
23
24
25
26
27

28
29
30
31
32

33
34
35
36








-
+





-
+




-
+




;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit keysmod))
(declare (uses commonmod))
;; (declare (uses commonmod))
(module keysmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
(import commonmod)
;; (import commonmod)

;; (use (prefix ulex ulex:))
(import srfi-13)

(include "common_records.scm")
;; (include "common_records.scm")


)

Modified megamod.scm from [8f577b7c68] to [6c4232b557].

︙
20
21
22
23
24
25
26

27


28
29
30
31
32
33
34

20
21
22
23
24
25
26
27

28
29
30
31
32
33
34
35
36








+
-
+
+









(declare (unit megamod))
;; (declare (uses commonmod))
;; (declare (uses dbmod))
;; ;;(declare (uses apimod))
;; (declare (uses ftail))
;; ;; (declare (uses rmtmod))

;; (declare (uses commonmod))
(declare (uses commonmod))

;; (declare (uses apimod))
;; (declare (uses archivemod))
;; (declare (uses clientmod))
;; (declare (uses dbmod))
;; (declare (uses dcommonmod))
;; (declare (uses envmod))
;; (declare (uses ezstepsmod))
︙
100
101
102
103
104
105
106

107
108
109
110
111
112
113

102
103
104
105
106
107
108
109
110
111
112
113
114
115
116








+









(use (prefix mtconfigf configf:))
(define read-config configf:read-config)
(define find-and-read-config configf:find-and-read-config)
(define config:eval-string-in-environment configf:eval-string-in-environment)

(import spiffy)
(import commonmod)

;; (import apimod)
;; (import archivemod)
;; (import clientmod)
;; (import commonmod)
;; (import dbmod)
;; (import dcommonmod)
︙

Modified megatest.scm from [0293a8aa08] to [e30d3b49bb].

︙
54
55
56
57
58
59
60

61
62
63
64
65
66
67

54
55
56
57
58
59
60
61
62
63
64
65
66
67
68








+








(import rmtmod)
(declare (uses dbmod))
(import dbmod)
(declare (uses megamod))
(import megamod)

;; invoke the imports
(declare (uses commonmod.import))
(declare (uses megamod.import))

(configf:set-debug-printers debug:print debug:print-info debug:print-error *default-log-port*)

;; (declare (uses tdb))
;; (declare (uses mt))
;; (declare (uses api))
︙

Modified processmod.scm from [6303547c57] to [860bc22580].

︙
26
27
28
29
30
31
32
33

34
35
36
37
38
39
40

26
27
28
29
30
31
32

33
34
35
36
37
38
39
40








-
+








	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
	format ports srfi-1 matchable regex directory-utils)
;; (import commonmod)
;; (use (prefix ulex ulex:))

(include "common_records.scm")
;; (include "common_records.scm")

;; 
;; 
;; ;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) 
;; ;;   execute thunk in context of environment modified as per this list
;; ;;   restore env to prior state then return value of eval'd thunk.
;; ;;   ** this is not thread safe **
︙

Modified rmtmod.scm from [606d22a19e] to [41d6e212da].

︙
16
17
18
19
20
21
22
23
24


25
26
27
28
29
30
31
32
33


34
35
36
37

38

16
17
18
19
20
21
22


23
24
25
26
27
28
29
30
31


32
33
34
35
36

37
38








-
-
+
+







-
-
+
+



-
+


;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit rmtmod))
;; (declare (uses commonmod))
(declare (uses dbmod))
(declare (uses megamod))
;; (declare (uses dbmod))
;; (declare (uses megamod))

(module rmtmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
;; (import commonmod) ;;; DO NOT ALLOW rmt*scm TO DEPEND ON common*scm!!!!
(import dbmod)
(import megamod)
;; (import dbmod)
;; (import megamod)

(use (prefix ulex ulex:))

(include "common_records.scm")
;; (include "common_records.scm")
)

Modified treemod.scm from [55ca98eed6] to [0a4dc2bcc5].

︙
22
23
24
25
26
27
28
29

30
31
32

22
23
24
25
26
27
28

29
30

31








-
+

-



(module treemod
	*
	
(import scheme chicken data-structures extras)
(import (prefix iup iup:)) ;; (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
;; (import commonmod) ;;; DO NOT ALLOW rmt*scm TO DEPEND ON common*scm!!!!

;; (include "common_records.scm")

;; (include "common_records.scm")
)

Modified vgmod.scm from [bff69312ab] to [1373ea9f94].

︙
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37

16
17
18
19
20
21
22

23
24
25
26
27
28
29
30
31




32








-









-
-
-
-


;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit vgmod))
;; (declare (uses commonmod))
;; (import commonmod)

(module vgmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
;; (import commonmod)
;; (use (prefix ulex ulex:))

;; (include "common_records.scm")
;; (include "vg_records.scm")
;; (include "vg-inc.scm")

)

This page was generated in about 0.137s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00