1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
|
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
28
29
30
31
32
33
34
35
36
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; Copyright 2006-2012, 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.
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(require-extension test)
(require-extension regex)
(require-extension srfi-18)
(import srfi-18)
(require-extension zmq)
(import zmq)
(define test-work-dir (current-directory))
;; read in all the _record files
(let ((files (glob "*_records.scm")))
(for-each
(lambda (file)
(print "Loading " file)
(load file))
files))
(define *runremote* #f)
;;======================================================================
;; P R O C E S S E S
;;======================================================================
(test "cmd-run-with-stderr->list" '("No such file or directory")
(let ((reslst (cmd-run-with-stderr->list "ls" "/tmp/ihadbetternotexist")))
|
| ︙ | | |
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(test #f "item_path GLOB ''" (db:patt->like "item_path" ""))
;; test:match->sqlqry
(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname GLOB '' AND item_path LIKE 'b%')"
(tests:match->sqlqry "a/b,a%,/b%"))
(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname LIKE '%' AND item_path LIKE 'b%')"
(tests:match->sqlqry "a/b,a%,%/b%"))
;;======================================================================
;; S E R V E R
;;======================================================================
(test "setup for run" #t (begin (setup-for-run)
(string? (getenv "MT_RUN_AREA_HOME"))))
(test "server-register, get-best-server" '("bob" 1234) (let ((res #f))
(open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live)
(set! res (open-run-close tasks:get-best-server tasks:open-db))
res))
(test "de-register server" #f (let ((res #f))
(open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234)
(open-run-close tasks:get-best-server tasks:open-db)))
;; (exit)
(set! *verbosity* 10)
(define server-pid (process-run "../../bin/megatest" (list "-server" "-" "-debug" (conc *verbosity*))))
(sleep 3)
(define th1 (make-thread (lambda ()(server:client-setup))))
(thread-start! th1)
(test #f #t (socket? *runremote*))
;;======================================================================
;; C O N F I G F I L E S
;;======================================================================
(define conffile #f)
(test "Read a config" #t (hash-table? (read-config "test.config" #f #f)))
(test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config" #f #f)))
|
| ︙ | | |
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
|
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
-
-
|
;; db
(define row (vector "a" "b" "c" "blah"))
(define header (list "col1" "col2" "col3" "col4"))
(test "Get row by header" "blah" (db:get-value-by-header row header "col4"))
;; (define *toppath* "tests")
(define *db* #f)
(test "setup for run" #t (begin (setup-for-run)
(string? (getenv "MT_RUN_AREA_HOME"))))
|
| ︙ | | |
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
|
-
+
|
(and (file-exists? "nada.sh")
(file-exists? "nada.csh"))))
(test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?))
(test "register-test, test info" "NOT_STARTED"
(begin
(cdb:tests-register-test *remoterun* 1 "nada" "")
(cdb:tests-register-test *runremote* 1 "nada" "")
;; (rdb:flush-queue)
(vector-ref (db:get-test-info *db* 1 "nada" "") 3)))
(test #f "NOT_STARTED"
(begin
(rdb:tests-register-test #f 1 "nada" "")
;; (rdb:flush-queue)
|
| ︙ | | |
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
|
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
|
-
-
-
-
-
-
-
-
-
+
|
;; (exit)
;;======================================================================
;; R E M O T E C A L L S
;;======================================================================
;; start a server process
(set! *verbosity* 10)
;; (define server-pid (process-run "../../bin/megatest" (list "-server" "-" "-debug" (conc *verbosity*))))
;; (sleep 2)
(define th1 (make-thread server:launch))
(thread-start! th1)
(apply cdb:test-set-status-state *remoterun* test-id params)
(apply cdb:test-set-status-state *runremote* test-id params)
(rdb:pass-fail-counts test-id (random 100) (random 100))
(rdb:test-rollup-test_data-pass-fail test-id)
(thread-sleep! 0.01)) ;; cache ordering granularity is at the second level. Should really be at the ms level
'(("COMPLETED" "PASS" #f)
("NOT_STARTED" "FAIL" "Just testing")
("NOT_STARTED" "FAIL" "Just testing")
("NOT_STARTED" "FAIL" "Just testing")
|
| ︙ | | |
330
331
332
333
334
335
336
337
338
339
|
362
363
364
365
366
367
368
369
370
371
372
373
|
+
+
|
(test "Rollup the run(s)" #t (begin
(runs:rollup-run keys (keys->alist keys "na") "rollup" "matt")
#t))
(hash-table-set! args:arg-hash ":runname" "%")
(test "Remove the rollup run" #t (begin (operate-on 'remove-runs)))
(thread-join! th1 th2 th3)
;; ADD ME!!!! (db:get-prereqs-not-met *db* 1 '("runfirst") "" mode: 'normal)
;; ADD ME!!!! (rdb:get-tests-for-run *db* 1 "runfirst" #f '() '())
|