Megatest: Check-in [3fda9c352d]

Overview

Comment:	Merged in try-nanomsg in prep for merging to one multi-transport code base
Downloads:	Tarball \| ZIP archive \| SQL archive
Timelines:	family \| ancestors \| descendants \| both \| multi-transport
Files:	files \| file ages \| folders
SHA1:	3fda9c352d15a48f02ea1dd6236ee3843bf55d16
User & Date:	matt on 2014-11-30 10:39:15
Other Links:	branch diff \| manifest \| tags

Context

2014-12-01
13:54		Merged v1.60 into multi-transport check-in: 1888a270be user: mrwellan tags: multi-transport
2014-11-30
10:39		Merged in try-nanomsg in prep for merging to one multi-transport code base check-in: 3fda9c352d user: matt tags: multi-transport
2014-11-29
22:44		Re-enable closing connections if open longer than the server timeout and no accesses Closed-Leaf check-in: cec4ee3511 user: matt tags: try-nanomsg
2014-03-05
00:44		Still blocks. check-in: 523082967f user: matt tags: multi-transport

Changes

Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified Makefile from [860d8c8d60] to [0861a039e1].

Modified api.scm from [be6d379826] to [080a657599].

Modified client.scm from [a20d04fe87] to [134437c4d3].

Modified common.scm from [4eb1de6666] to [d99f383a66].

Modified common_records.scm from [8d360e8ca7] to [08c9f6257d].

Modified configf.scm from [4398556a5c] to [3684e66c72].

Modified dashboard-tests.scm from [0f843da842] to [224dddeb50].

Modified dashboard.scm from [16f8f4859b] to [6d6a8350b9].

Added datashare-testing/.sd.config version [3db28d187c].

Added datashare.scm version [2abd8aec1c].

Modified db.scm from [4736d6ba1e] to [ad92b83fd4].

Modified db_records.scm from [ee094931e6] to [858bdddce0].

Modified dcommon.scm from [6ced1731f9] to [31fd59f2b3].

Modified docs/manual/megatest_manual.html from [20d78e9a28] to [151c9a3dda].

Modified docs/manual/reference.txt from [b45aa0231c] to [ddb57ef21a].

Modified docs/manual/server.png from [ae7d7ee58e] to [a508d3edd1].

cannot compute difference between binary files

Added docs/megatest-state-status.dot version [45d0ee8608].

Modified docs/megatest-training.odp from [f0451ad5da] to [8b1c9793d2].

cannot compute difference between binary files

Modified http-transport.scm from [b1f2a5135d] to [2164d5e761].

Modified launch.scm from [ffa12b2653] to [111f911e42].

Modified lock-queue.scm from [e008712ec5] to [fb7e24faf1].

Modified megatest-version.scm from [c3e2c52b04] to [9b8927108a].

Modified megatest.scm from [9ad538c10f] to [9b7f06366e].

Modified mt.scm from [029729b148] to [15956fcc00].

Modified newdashboard.scm from [4e9877b3af] to [c632e597af].

Added nmsg-transport.scm version [2023441101].

Added portlogger.scm version [c19f5a6299].

Modified process.scm from [88799f98f8] to [781c177a90].

Modified rmt.scm from [4f653be615] to [f7b514fa2e].

Modified runconfig.scm from [4e3a96ccb1] to [d97360c67a].

Modified runs.scm from [f4abbaad2e] to [f2976f1213].

Modified server.scm from [be86b1fb3b] to [d9e8792ebb].

Modified synchash.scm from [68c033427e] to [9881f5a738].

Modified tasks.scm from [d0fac30298] to [299efaed94].

Modified tdb.scm from [fd0c5aa4a1] to [575d5c7ba8].

Added testnanomsg/basic-req-rep.scm version [1436c827c9].

Added testnanomsg/mockupclient.scm version [63a8c6685a].

Added testnanomsg/mockupclientlib.scm version [3b245ba7a9].

Added testnanomsg/mockupserver.scm version [a4d3e5594c].

Added testnanomsg/pipeline.scm version [1d4d831eb6].

Added testnanomsg/req-rep-client.scm version [7998d54555].

Added testnanomsg/req-rep-server.scm version [d9de6da037].

Added testnanomsg/req-rep.scm version [b77ebf1421].

Modified tests.scm from [6b6e58b833] to [2a580a2e0e].

Modified tests/Makefile from [919b1cc16e] to [608cf0bdb8].

Modified tests/fdktestqa/fdk.config from [3481fe6c37] to [bb2780b886].

Modified tests/fdktestqa/testqa/Makefile from [492b4d14b9] to [d3de829000].

Modified tests/fdktestqa/testqa/configs/megatest.abc.config from [b0c9fe881b] to [a1a8a77b6d].

Modified tests/fdktestqa/testqa/configs/megatest.def.config from [614ea68417] to [1df0e5e24a].

Modified tests/fdktestqa/testqa/megatest.config from [bc9a54cc82] to [0bd41b6735].

Modified tests/fdktestqa/testqa/tests/bigrun/step1.sh from [580746490f] to [e700391a61].

Modified tests/fdktestqa/testqa/tests/bigrun/testconfig from [a953628936] to [edca99e35e].

Modified tests/fdktestqa/testqa/tests/bigrun2/testconfig from [c505730d37] to [ccc63b9335].

Modified tests/fdktestqa/testqa/tests/bigrun3/testconfig from [50bfaafec8] to [e9786b9270].

Modified tests/fullrun/config/mt_include_1.config from [e1668a96e9] to [f2402f5b23].

Modified tests/fullrun/megatest.config from [b7eeb9c61e] to [54ee5ec660].

Modified tests/fullrun/runconfigs.config from [cdf025da8a] to [30a30e595a].

Modified tests/fullrun/tests/exit_0/testconfig from [475b97c77b] to [5010ef5eb6].

Added tests/fullrun/tests/test_mt_vars/eval_vars.sh version [786761600e].

Modified tests/fullrun/tests/test_mt_vars/testconfig from [a0c61adcaf] to [0d7c3216f9].

tests/installall/config/megatest.config.dat became a regular file with contents [736a5da885].

tests/installall/config/runconfigs.config.dat became a regular file with contents [3b8f260acb].

Modified tests/mintest/megatest.config from [158955d103] to [74b434d2c6].

Modified tests/rununittest.sh from [f7741d546c] to [d9bb67915f].

Modified tests/simplerun/megatest.config from [a2b32bd6f4] to [4850198caf].

Name change from tests/simplerun/tests/test2/step1.sh.sh to tests/simplerun/tests/test2/step1.sh.

Name change from tests/simplerun/tests/test2/step2.sh.sh to tests/simplerun/tests/test2/step2.sh.

Added

 > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > >

tests/stats.txt version [2a209bca81]. class="diffln difflnl">

 difftxtl"> difflnr"> class="difftxt difftxtr"> a1236d6bf92ec5cb8955f490761b21b0d3eea9d3 Count   TotTime   Avg        1035    237.0                0.23 884    119.0                0.13 884    169.0                0.19 884    732.0                0.83 673    122.0                0.18 476      1.0                0.00 356     42.0                0.12 203     24.0                0.12 159     39.0                0.25 140     30.0                0.21 128     98.0                0.77 94     45.0                0.48 32      0.0                0.00 25      4.0                0.16 12      4.0                0.33 8      0.0                0.00 5      2.0                0.40 4      0.0                0.00 4      5.0                1.25 4     15.0                3.75 4     15.0                3.75 first three functions above to sqlite3:first-result Count   TotTime   Avg        1138    179.0                0.16 987     91.0                0.09 987    171.0                0.17 987    892.0                0.90 672     95.0                0.14 476      0.0                0.00 355     41.0                0.12 203     15.0                0.07 159     30.0                0.19 140     22.0                0.16 128    855.0                6.68 94     20.0                0.21 36      1.0                0.03 24      5.0                0.21 12      2.0                0.17 9      0.0                0.00 5      1.0                0.20 4      1.0                0.25 4     11.0                2.75 4      0.0                0.00 4     17.0                4.25 run, converted one or two non-relevant functions to sqlite3:first-result Count   TotTime   Avg        987    157.0                0.16 836     79.0                0.09 836    121.0                0.14 836    513.0                0.61 673     85.0                0.13 476      0.0                0.00 356     32.0                0.09 203     19.0                0.09 159     27.0                0.17 140     23.0                0.16 128     35.0                0.27 94     20.0                0.21 40      0.0                0.00 25      5.0                0.20 12      1.0                0.08 10      0.0                0.00 5      0.0                0.00 4     15.0                3.75 4      2.0                0.50 4      1.0                0.25 4     12.0                3.00

Modified tests/tests.scm
from [a780d57ffe]
to [9d9074d93d].


︙ ︙ 
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36






(let ((files (glob "*_records.scm")))
  (for-each
   (lambda (file)
     (print "Loading " file)
     (load file))
   files))

(define *runremote* #f)

(let* ((unit-test-name (list-ref (argv) 4))
       (fname          (conc "../unittests/" unit-test-name ".scm")))
  (if (file-exists? fname)
      (load fname)
      (print "ERROR: Unit test " unit-test-name " not found in unittests directory")))














<
<






>
>
>
>
>
>
22
23
24
25
26
27
28


29
30
31
32
33
34
35
36
37
38
39
40
(let ((files (glob "*_records.scm")))
  (for-each
   (lambda (file)
     (print "Loading " file)
     (load file))
   files))



(let* ((unit-test-name (list-ref (argv) 4))
       (fname          (conc "../unittests/" unit-test-name ".scm")))
  (if (file-exists? fname)
      (load fname)
      (print "ERROR: Unit test " unit-test-name " not found in unittests directory")))


 (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/" "%abc%")
 (list "abc" "abc"   "abcd"   "abc"     "abc"     "a"         "abc"     "def"    "ghi"   "a" "a"  "a"  "a" "abc")
 (list   ""  ""      "cde"    "cde"     "cde"     ""            ""      "a"       "b"    ""  "b"  ""   "b" "abc")
 (list   #t    #t       #t    #f           #f      #t           #t       #t       #f     #t  #t   #t    #f #t))





Modified tests/unittests/basicserver.scm
from [b1c30eb42e]
to [8806c7e3ae].

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

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

;;======================================================================
;; S E R V E R
;;======================================================================

;; Run like this:
;;
;;  (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)

(set! *transport-type* 'http)


(test "setup for run" #t (begin (setup-for-run)
				(string? (getenv "MT_RUN_AREA_HOME"))))


(test "server-register, get-best-server" #t (let ((res #f))



					      (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http)










					      (set! res (open-run-close tasks:get-best-server tasks:open-db))
					      (number? (vector-ref res 3))))



(test "de-register server" #f (let ((res #f))


				(open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234)
				(vector? (open-run-close tasks:get-best-server tasks:open-db))))


(define server-pid #f)











;; Not sure how the following should work, replacing it with system of megatest -server
;; (test "launch server" #t (let ((pid (process-fork (lambda ()
;; 						    ;; (daemon:ize)

;; 						    (server:launch 'http)))))
;; 			   (set! server-pid pid)

;; 			   (number? pid)))
(system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &")




(let loop ((n 10))
  (thread-sleep! 1) ;; need to wait for server to start.
  (let ((res (open-run-close tasks:get-best-server tasks:open-db)))

    (print "tasks:get-best-server returned " res)

    (if (and (not res)
	     (> n 0))



	(loop (- n 1)))))








(test "get-best-server" #t (begin 



			     (client:launch)
			     (let ((dat (open-run-close tasks:get-best-server tasks:open-db)))
			       (vector? dat))))

(define *keys*               (keys:config-get-fields *configdat*))

(define *keyvals*            (keys:target->keyval *keys* "a/b/c"))





(test #f #t                       (string? (car *runremote*)))

(test #f '(#t "successful login") (rmt:login)) ;;  *runremote* *toppath* *my-client-signature*)))






(test #f #f                       (rmt:get-test-info-by-id 99)) ;; get non-existant test




;; RUNS

(test #f 1                        (rmt:register-run  *keyvals* "firstrun" "new" "n/a" (current-user-name)))
(test "get run info"  "firstrun"  (let ((rinfo (rmt:get-run-info 1)))


				    (vector-ref (vector-ref rinfo 1) 3)))
(test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1))




















































;; TESTS
(test "get tests (no data)" '()   (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))
(test "register test"       #t    (rmt:general-call 'register-test 1 "test1" ""))
(test "get tests (some data)"  1  (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)))
(test "get test id"            1  (rmt:get-test-id 1 "test1" ""))
(test "sync back"              #t (> (rmt:sync-inmem->db) 0))
(test "get test id from main"  1  (db:get-test-id *db* 1 "test1" ""))
(test "get keys"               #t (list? (rmt:get-keys)))
(test "set comment"            #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t))
(test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1)))
					  (db:test-get-comment trec)))

;; MORE RUNS
(test "get runs"  #t (let* ((runs   (rmt:get-runs "%" #f #f '()))
			    (header (vector-ref runs 0))
			    (data   (vector-ref runs 1)))
		       (and (list?   header)
			    (list?   data)
			    (vector? (car data)))))

(test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2))
(test "get testinfo"       "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2))

;;======================================================================
;; D B
;;======================================================================

(test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1))
(test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1)))
				  (+ (db:test-get-pass_count dat)
				     (db:test-get-fail_count dat))))

(define testregistry (make-hash-table))
(for-each
 (lambda (tname)
   (for-each
    (lambda (itempath)
      (let ((tkey  (conc tname "/" itempath))
	    (rpass (random 10))
	    (rfail (random 10)))
	(hash-table-set! testregistry tkey (list tname itempath))
	(rmt:general-call 'register-test 1 tname itempath)
	(let* ((tid  (rmt:get-test-id 1 tname itempath))
	       (tdat (rmt:get-test-info-by-id tid)))
	  (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat))
	  (let* ((resdat (rmt:get-test-info-by-id tid)))
	    (test "set/get pass fail counts" (list rpass rfail)
		  (list (db:test-get-pass_count resdat)
			(db:test-get-fail_count resdat)))))))
    (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j")))
 (list "test1" "test2" "test3" "test4" "test5"))


(test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))









|

|
>

|
|

>
|
>
>
>
|
>
>
>
>
>
>
>
>
>
>
|
|
>
|
>
|
>
>
|
|
>

|
>
>
>
>
>
>
>
>
>
>
|
<
<
<
>
|
<
>
|
<
>
>
>

|
<
<
>
|
>
|
|
>
>
>
|
>
>
>

>
>
>
>
|
>
>
>
|
|
|
|
<
>
|
>
>

>
>
|
>
|
>
>
>
>
>

<
>

>
>
|
>
|
<
>
>
|
|

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>

>
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
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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
;;======================================================================
;; S E R V E R
;;======================================================================

;; Run like this:
;;
;;  ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)

(delete-file* "logs/1.log")
(define run-id 1)

(test "setup for run" #t (begin (launch:setup-for-run)
 				(string? (getenv "MT_RUN_AREA_HOME"))))

;; NON Server tests go here

(test #f #f (db:dbdat-get-path *db*))
(test #f #f (db:get-run-name-from-id *db* run-id))
;; (test #f '("SYSTEM" "RELEASE") (rmt:get-keys))

;; (exit)

;; Server tests go here 
(for-each (lambda (run-id)
(test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))
(server:kind-run run-id)
(test "did server start within 20 seconds?"
      #t
      (let loop ((remtries 20)
		 (running (tasks:server-running-or-starting? (db:delay-if-busy
							      (tasks:open-db))
							     run-id)))
	(if running 
	    (> running 0)
	    (if (> remtries 0)
		(begin
		  (thread-sleep! 1)
		  (loop (- remtries 1)
			(tasks:server-running-or-starting? (db:delay-if-busy
							    (tasks:open-db))
							   run-id)))))))

(test "did server become available" #t
      (let loop ((remtries 10)
		 (res      (tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id)))
	(if res
	    (vector? res)
	    (begin
	      (if (> remtries 0)
		  (begin
		    (thread-sleep! 1.1)
		    (loop (- remtries 1)(tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id)))
		  res)))))
)



(list 0 1))
(define user    (current-user-name))

(define runname "mytestrun")
(define keys    (rmt:get-keys))

(define runinfo #f)
(define keyvals '(("SYSTEM" "abc")("RELEASE" "def")))
(define header  (vector "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time"))

;; Setup


;;
(test #f #f  (not (client:setup run-id)))
(test #f #f  (not (hash-table-ref/default *runremote* run-id #f)))

;; Login
;;
(test #f '(#t "successful login") (rmt:login-no-auto-client-setup (hash-table-ref/default *runremote* run-id #f) run-id))
(test #f '(#t "successful login") (rmt:login run-id))

;; Keys
;;
(test #f '("SYSTEM" "RELEASE")  (rmt:get-keys))

;; No data in db
;;
(test #f '() (rmt:get-all-run-ids))
(test #f #f  (rmt:get-run-name-from-id run-id))
(test #f 
      (let ((runrec (vector #f #f)))
	(vector-set! runrec header 0)
	(vector-set! runrec (vector #f       #f        #f   #f) 1)
	runrec)
      (rmt:get-run-info run-id))

;; Insert data into db

;;
(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user))
;; (test #f #f (rmt:get-runs-by-patt keys runname))
(test #f #t (rmt:general-call 'register-test run-id run-id "test-one" ""))

;; With data in db
;;
(test #f '(1)    (rmt:get-all-run-ids))
(test #f runname (rmt:get-run-name-from-id run-id))
(test #f 
      runname
      (let ((run-info (rmt:get-run-info run-id)))
	(db:get-value-by-header (db:get-rows run-info)
				(db:get-header run-info)
				"runname")))


      ;; (vector header (vector "abc" "def" 1 "mytestrun" "new" "n/a" "matt" 1416280640.0))

(for-each (lambda (run-id)
;; test killing server
;;
(tasks:kill-server-run-id run-id)


(test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))
)
(list 0 1))
;; (test #f #f (client:setup run-id))

;; (set! *transport-type* 'http)
;; 
;; (test "setup for run" #t (begin (launch:setup-for-run)
;; 				(string? (getenv "MT_RUN_AREA_HOME"))))
;; 
;; (test "server-register, get-best-server" #t (let ((res #f))
;; 					      (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http)
;; 					      (set! res (open-run-close tasks:get-best-server tasks:open-db))
;; 					      (number? (vector-ref res 3))))
;; 
;; (test "de-register server" #f (let ((res #f))
;; 				(open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234)
;; 				(vector? (open-run-close tasks:get-best-server tasks:open-db))))
;; 
;; (define server-pid #f)
;; 
;; ;; Not sure how the following should work, replacing it with system of megatest -server
;; ;; (test "launch server" #t (let ((pid (process-fork (lambda ()
;; ;; 						    ;; (daemon:ize)
;; ;; 						    (server:launch 'http)))))
;; ;; 			   (set! server-pid pid)
;; ;; 			   (number? pid)))
;; (system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &")
;; 
;; (let loop ((n 10))
;;   (thread-sleep! 1) ;; need to wait for server to start.
;;   (let ((res (open-run-close tasks:get-best-server tasks:open-db)))
;;     (print "tasks:get-best-server returned " res)
;;     (if (and (not res)
;; 	     (> n 0))
;; 	(loop (- n 1)))))
;; 
;; (test "get-best-server" #t (begin 
;; 			     (client:launch)
;; 			     (let ((dat (open-run-close tasks:get-best-server tasks:open-db)))
;; 			       (vector? dat))))
;; 
;; (define *keys*               (keys:config-get-fields *configdat*))
;; (define *keyvals*            (keys:target->keyval *keys* "a/b/c"))
;; 
;; (test #f #t                       (string? (car *runremote*)))
;; (test #f '(#t "successful login") (rmt:login)) ;;  *runremote* *toppath* *my-client-signature*)))
;; 
;; (test #f #f                       (rmt:get-test-info-by-id 99)) ;; get non-existant test
;; 
;; ;; RUNS
;; (test #f 1                        (rmt:register-run  *keyvals* "firstrun" "new" "n/a" (current-user-name)))
;; (test "get run info"  "firstrun"  (let ((rinfo (rmt:get-run-info 1)))
;; 				    (vector-ref (vector-ref rinfo 1) 3)))
;; (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1))
;; 
;; ;; TESTS
;; (test "get tests (no data)" '()   (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))
;; (test "register test"       #t    (rmt:general-call 'register-test 1 "test1" ""))
;; (test "get tests (some data)"  1  (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)))
;; (test "get test id"            1  (rmt:get-test-id 1 "test1" ""))
;; (test "sync back"              #t (> (rmt:sync-inmem->db) 0))
;; (test "get test id from main"  1  (db:get-test-id *db* 1 "test1" ""))
;; (test "get keys"               #t (list? (rmt:get-keys)))
;; (test "set comment"            #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t))
;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1)))
;; 					  (db:test-get-comment trec)))
;; 
;; ;; MORE RUNS
;; (test "get runs"  #t (let* ((runs   (rmt:get-runs "%" #f #f '()))
;; 			    (header (vector-ref runs 0))
;; 			    (data   (vector-ref runs 1)))
;; 		       (and (list?   header)
;; 			    (list?   data)
;; 			    (vector? (car data)))))
;; 
;; (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2))
;; (test "get testinfo"       "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2))
;; 
;; ;;======================================================================
;; ;; D B
;; ;;======================================================================
;; 
;; (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1))
;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1)))
;; 				  (+ (db:test-get-pass_count dat)
;; 				     (db:test-get-fail_count dat))))
;; 
;; (define testregistry (make-hash-table))
;; (for-each
;;  (lambda (tname)
;;    (for-each
;;     (lambda (itempath)
;;       (let ((tkey  (conc tname "/" itempath))
;; 	    (rpass (random 10))
;; 	    (rfail (random 10)))
;; 	(hash-table-set! testregistry tkey (list tname itempath))
;; 	(rmt:general-call 'register-test 1 tname itempath)
;; 	(let* ((tid  (rmt:get-test-id 1 tname itempath))
;; 	       (tdat (rmt:get-test-info-by-id tid)))
;; 	  (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat))
;; 	  (let* ((resdat (rmt:get-test-info-by-id tid)))
;; 	    (test "set/get pass fail counts" (list rpass rfail)
;; 		  (list (db:test-get-pass_count resdat)
;; 			(db:test-get-fail_count resdat)))))))
;;     (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j")))
;;  (list "test1" "test2" "test3" "test4" "test5"))
;; 
;; 
;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))
;; 

(exit)




Modified tree.scm
from [e7e38b65a4]
to [02f8628298].


︙ ︙ 
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
		  (if (> depth node-depth) ;; (+ 1 node-depth))
		      #f
		      (loop hed tal depth (+ nodenum 1)))))
	    #f))))

;; top is the top node name zeroeth node VALUE=0
(define (tree:add-node obj top nodelst #!key (userdata #f))

  (if (not (iup:attribute obj "TITLE0"))
      (iup:attribute-set! obj "ADDBRANCH0" top))
  (cond
   ((not (string=? top (iup:attribute obj "TITLE0")))
    (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0")))
   ((null? nodelst))
   (else
    (let loop ((hed      (car nodelst))
	       (tal      (cdr nodelst))
	       (depth    1)
	       (pathl    (list top)))
      ;; Because the tree dialog changes node numbers when
      ;; nodes are added or removed we must look up nodes
      ;; each and every time. 0 is the top node so default
      ;; to that.
      (let* ((newpath    (append pathl (list hed)))
	     (parentnode (tree:find-node obj pathl))
	     (nodenum    (tree:find-node obj newpath)))
	;; Add the branch under lastnode if not found
	(if (not nodenum)
	    (begin
	      (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed)

	      (if userdata
		  (iup:attribute-set! obj (conc "USERDATA"   parentnode) userdata))
	      (if (null? tal)
		  #t
		  ;; reset to top
		  (loop (car nodelst)(cdr nodelst) 1 (list top)))) 
	    (if (null? tal) ;; if null here then this path has already been added







>
|


|


















>







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
		  (if (> depth node-depth) ;; (+ 1 node-depth))
		      #f
		      (loop hed tal depth (+ nodenum 1)))))
	    #f))))

;; top is the top node name zeroeth node VALUE=0
(define (tree:add-node obj top nodelst #!key (userdata #f))
  (if (or (not (string? (iup:attribute obj "TITLE0")))
	  (string-null? (iup:attribute obj "TITLE0")))
      (iup:attribute-set! obj "ADDBRANCH0" top))
  (cond
   ((not (equal? top (iup:attribute obj "TITLE0")))
    (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0")))
   ((null? nodelst))
   (else
    (let loop ((hed      (car nodelst))
	       (tal      (cdr nodelst))
	       (depth    1)
	       (pathl    (list top)))
      ;; Because the tree dialog changes node numbers when
      ;; nodes are added or removed we must look up nodes
      ;; each and every time. 0 is the top node so default
      ;; to that.
      (let* ((newpath    (append pathl (list hed)))
	     (parentnode (tree:find-node obj pathl))
	     (nodenum    (tree:find-node obj newpath)))
	;; Add the branch under lastnode if not found
	(if (not nodenum)
	    (begin
	      (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed)
		;; ERROR? ADDING DATA TO PARENT, DONT WE WANT IT ON CREATED NODE?
	      (if userdata
		  (iup:attribute-set! obj (conc "USERDATA"   parentnode) userdata))
	      (if (null? tal)
		  #t
		  ;; reset to top
		  (loop (car nodelst)(cdr nodelst) 1 (list top)))) 
	    (if (null? tal) ;; if null here then this path has already been added


︙ ︙ 
109
110
111
112
113
114
115
116
























			   (take path node-depth)
			   path))
	   (newpath    (append trimpath (list node-title))))
      (if (>= currnode nodenum)
	  newpath
	  (loop (+ currnode 1)
		newpath)))))
	































|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
			   (take path node-depth)
			   path))
	   (newpath    (append trimpath (list node-title))))
      (if (>= currnode nodenum)
	  newpath
	  (loop (+ currnode 1)
		newpath)))))

(define (tree:delete-node obj top node-path) ;; node-path is a list of strings
  (let ((id  (tree:find-node obj (cons top node-path))))
    (print "Found node to remove " id " for path " top " " node-path)
    (iup:attribute-set! obj (conc "DELNODE" id) "SELECTED")))
	
#|

  (let* ((tb      (iup:treebox
                   #:value 0
                   #:name "Runs"
                   #:expand "YES"
                   #:addexpanded "NO"
                   #:selection-cb
                   (lambda (obj id state)
                     ;; (print "obj: " obj ", id: " id ", state: " state)
                     (let* ((run-path (tree:node->path obj id))
                            (run-id   (tree-path->run-id (cdr run-path))))
                       (if run-id
                           (begin
                             (dboard:data-set-curr-run-id! *data* run-id)
                             (dashboard:update-run-summary-tab)))
                       ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
                       ))))
|#




Modified txtdb/txtdb.scm
from [cf8a5ae239]
to [e82989d975].


︙ ︙ 
13
14
15
16
17
18
19

20
21
22
23
24
25
26
(use sxml-modifications)
(use regex)
(use srfi-69)
(use regex-case)
(use posix)
(use json)
(use csv)


(include "../megatest-fossil-hash.scm")

;; Read a non-compressed gnumeric file
(define (refdb:read-gnumeric-xml fname)
  (with-input-from-file fname
    (lambda ()







>







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
(use sxml-modifications)
(use regex)
(use srfi-69)
(use regex-case)
(use posix)
(use json)
(use csv)
(use srfi-18)

(include "../megatest-fossil-hash.scm")

;; Read a non-compressed gnumeric file
(define (refdb:read-gnumeric-xml fname)
  (with-input-from-file fname
    (lambda ()


︙ ︙ 
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
							  (hash-table-ref/default cols colname '()))))))))
	      cells)
    (let ((ref-colnums (map (lambda (c)
			      (list (cdr c)(car c)))
			    (hash-table->alist colnums))))
      (with-output-to-file (conc targdir "/" sheet-name ".dat")
	(lambda ()
	  (print "[" col0title "]")
	  (for-each (lambda (colname)
		      (print "[" colname "]")
		      (for-each (lambda (row)
				  (let ((key (car row))
					(val (cadr row)))
				    (if (string-search comment-rx key)
					(print val)
					(if (string-search blank-rx key)
					    (print)


					    (print key " " val)))))
				(reverse (hash-table-ref cols colname)))
		      ;; (print)
		      )
		    (sort (hash-table-keys cols)(lambda (a b)
						  (let ((colnum-a (assoc a ref-colnums))
							(colnum-b (assoc b ref-colnums)))
						    (if (and colnum-a colnum-b)







|









>
>
|







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
							  (hash-table-ref/default cols colname '()))))))))
	      cells)
    (let ((ref-colnums (map (lambda (c)
			      (list (cdr c)(car c)))
			    (hash-table->alist colnums))))
      (with-output-to-file (conc targdir "/" sheet-name ".dat")
	(lambda ()
	  (if (not (string-null? col0title))(print "[" col0title "]"))
	  (for-each (lambda (colname)
		      (print "[" colname "]")
		      (for-each (lambda (row)
				  (let ((key (car row))
					(val (cadr row)))
				    (if (string-search comment-rx key)
					(print val)
					(if (string-search blank-rx key)
					    (print)
					    (if (string-search " " key)
						(print "\"" key "\" " val)
						(print key " " val))))))
				(reverse (hash-table-ref cols colname)))
		      ;; (print)
		      )
		    (sort (hash-table-keys cols)(lambda (a b)
						  (let ((colnum-a (assoc a ref-colnums))
							(colnum-b (assoc b ref-colnums)))
						    (if (and colnum-a colnum-b)


︙ ︙ 
214
215
216
217
218
219
220

221
222
223
224
225
226
227

(define (hash-table-reverse-lookup ht val)
  (hash-table-fold ht (lambda (k v res)(if (equal? v val) k res)) #f))

(define (read-dat fname)
  (let ((section-rx  (regexp "^\\[(.*)\\]\\s*$"))
	(comment-rx  (regexp "^#.*"))          ;; This means a cell name cannot start with #

	(cell-rx     (regexp "^(\\S+) (.*)$")) ;; One space only for the cellname content separator 
	(blank-rx    (regexp "^\\s*$"))
	(continue-rx (regexp ".*\\\\$"))
	(var-no-val-rx (regexp "^(\\S+)\\s*$"))
	(inp         (open-input-file fname))
	(cmnt-indx   (make-hash-table))
	(blnk-indx   (make-hash-table))







>







217
218
219
220
221
222
223
224
225
226
227
228
229
230
231

(define (hash-table-reverse-lookup ht val)
  (hash-table-fold ht (lambda (k v res)(if (equal? v val) k res)) #f))

(define (read-dat fname)
  (let ((section-rx  (regexp "^\\[(.*)\\]\\s*$"))
	(comment-rx  (regexp "^#.*"))          ;; This means a cell name cannot start with #
	(quoted-cell-rx (regexp "^\"([^\"]*)\" (.*)$"))
	(cell-rx     (regexp "^(\\S+) (.*)$")) ;; One space only for the cellname content separator 
	(blank-rx    (regexp "^\\s*$"))
	(continue-rx (regexp ".*\\\\$"))
	(var-no-val-rx (regexp "^(\\S+)\\s*$"))
	(inp         (open-input-file fname))
	(cmnt-indx   (make-hash-table))
	(blnk-indx   (make-hash-table))


︙ ︙ 
249
250
251
252
253
254
255



256
257
258
259
260
261
262
263
264
265
266
267

268
269
270
271
272
273
274
					  (cons (list (conc "#BLNK" curr-indx) section " ") res))))
	   (section-rx (x sname)  (begin
				    (if (not first-section)
					(set! first-section sname))
				    (loop (read-line inp) 
					  sname 
					  res)))



	   (cell-rx   (x k v)     (loop (read-line inp)
					section
					(cons (list k section v) res)))
	   (var-no-val-rx (x k)   (loop (read-line inp)
					section
					(cons (list k section "") res)))
	   (else                  (begin
				    (print "ERROR: Unrecognised line in input file " fname ", ignoring it")
				    (loop (read-line inp) section res))))))))

(define (get-value-type val expressions)
  (cond 

   ((string->number val) '(ValueType "40"))
   ((equal? val "")      '(ValueType "60"))
   ((equal? (substring val 0 1) "=")
    (let ((exid (hash-table-ref/default expressions val #f)))
      (if exid 
	  (list 'ExprID exid)
	  (let* ((values  (hash-table-keys expressions)) ;; note, values are the id numbers







>
>
>












>







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
279
280
281
282
					  (cons (list (conc "#BLNK" curr-indx) section " ") res))))
	   (section-rx (x sname)  (begin
				    (if (not first-section)
					(set! first-section sname))
				    (loop (read-line inp) 
					  sname 
					  res)))
	   (quoted-cell-rx (x k v)(loop (read-line inp)
					section
					(cons (list k section v) res)))
	   (cell-rx   (x k v)     (loop (read-line inp)
					section
					(cons (list k section v) res)))
	   (var-no-val-rx (x k)   (loop (read-line inp)
					section
					(cons (list k section "") res)))
	   (else                  (begin
				    (print "ERROR: Unrecognised line in input file " fname ", ignoring it")
				    (loop (read-line inp) section res))))))))

(define (get-value-type val expressions)
  (cond 
   ((not val)            '(ValueType "60"))
   ((string->number val) '(ValueType "40"))
   ((equal? val "")      '(ValueType "60"))
   ((equal? (substring val 0 1) "=")
    (let ((exid (hash-table-ref/default expressions val #f)))
      (if exid 
	  (list 'ExprID exid)
	  (let* ((values  (hash-table-keys expressions)) ;; note, values are the id numbers


︙ ︙ 
452
453
454
455
456
457
458
459

460






461









462
463
464
465
466
467
468
	(print)
	(print "Don't forget to remove the old files from your revision control system and add the new.")
	(exit)))
  (let* ((dbname  (pathname-strip-directory path))
	 (tmpf    (conc (create-temporary-file dbname) ".gnumeric")))
    (if (file-exists? (conc path "/sheet-names.cfg"))
	(refdb-export path tmpf))
    (let ((pid (process-run "gnumeric" (list tmpf))))

      (process-wait pid)






      (import-gnumeric-file tmpf path))))










;;======================================================================
;; This routine dispaches or executes most of the commands for refdb
;;======================================================================
;;
(define (process-action action-str . param)
  (let ((num-params (length param))







|
>
|
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>







460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
	(print)
	(print "Don't forget to remove the old files from your revision control system and add the new.")
	(exit)))
  (let* ((dbname  (pathname-strip-directory path))
	 (tmpf    (conc (create-temporary-file dbname) ".gnumeric")))
    (if (file-exists? (conc path "/sheet-names.cfg"))
	(refdb-export path tmpf))
    (let* ((pid (process-run "gnumeric" (list tmpf))))
      (let loop ((last-mod-time (current-seconds)))
	(let-values (((pid-code exit-status exit-signal)(process-wait pid #t)))
           (if (eq? pid-code 0) ;; still going
	       (if (file-exists? tmpf)
		   (let ((mod-time (file-modification-time tmpf)))
		     (if (> mod-time last-mod-time)
			 (begin
			   (print "saved data to " path)
			   (import-gnumeric-file tmpf path)))
		     (thread-sleep! 0.5)
		     (loop mod-time))
		   (begin
		     (thread-sleep! 0.5)
		     (loop last-mod-time))))))
      ;; all done
      (print "all done, writing new data to " path)
      (import-gnumeric-file tmpf path)
      (print "data written, exiting refdb edit."))))

;;======================================================================
;; This routine dispaches or executes most of the commands for refdb
;;======================================================================
;;
(define (process-action action-str . param)
  (let ((num-params (length param))


︙ ︙ 



Modified utils/Makefile.installall
from [be549557c7]
to [507fd637d5].

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
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

# Copyright 2013, 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.



help :
	@echo You may need to do the following first:
	@echo sudo apt-get install libreadline-dev
	@echo sudo apt-get install libwebkitgtk-dev 
	@echo sudo apt-get install libmotif3 -OR- set KTYPE=26g4
	@echo KTYPE can be 26, 26g4, or 32
	@echo KTYPE=$KTYPE
	@echo You are using PREFIX=$PREFIX
	@echo You are using proxy="$(proxy)"
	@echo If needed set proxy to host.dom:port
	@echo 
	@echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :"
	@echo ADDITIONAL_LIBPATH=$(ADDITIONAL_LIBPATH)
	@echo  
	@echo To use previous IUP libraries set USEOLDIUP to yes
	@echo USEOLDIUP=$(USEOLDIUP)
	@echo 
	@echo To make all do: make all

# Put the installation here
ifeq ($(PREFIX),)
PREFIX=$(PWD)/target
endif

# Set this on the command line of your make call if needed: make PROXY=host.com:1234
PROXY=

# Select IUP library type
KTYPE=26g4

# Select version of chicken, sqlite3 etc
CHICKEN_VERSION=4.8.0
SQLITE3_VERSION=3071401





# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars





#
# Derived variables
#

ifeq ($(PROXY),)
PROX=
else
http_proxy=http://$(PROXY)
PROX="-proxy $(PROXY)"
endif

BUILDHOME=$(PWD)
PATH:=$(PREFIX)/bin:$(PATH)
LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH)
LD_LIBRARY_PATH=$(LIBPATH)
CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install

|








>
>



|
|
<
|
|
|
|
|
<
<
|
<
<











<
<
<

|
|
>

>
>
>

|
>
>
>
>






|

|
|







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
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

# Copyright 2013,2014 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.

# make PREFIX=/mfs/pkgs/chicken/chicken-core all

help :
	@echo You may need to do the following first:
	@echo sudo apt-get install libreadline-dev
	@echo sudo apt-get install libwebkitgtk-dev libfreetype6-dev libx11-dev libxpm-dev libxmu-dev libxft-dev libgtk2.0-dev libgl1-mesa-dev libglu1-mesa-dev libpangox-1.0-dev bison
	@echo sudo apt-get install libmotif3

	@echo For IUP set IUPBRANCH, currently $(IUPBRANCH)
	@echo You are using PREFIX=$(PREFIX)
	@echo You are using PROXY="$(PROXY)"
	@echo If needed set PROXY to host.dom:port
	@echo   http_proxy=$(http_proxy)


	@echo   PROX=$(PROX)


	@echo 
	@echo To make all do: make all

# Put the installation here
ifeq ($(PREFIX),)
PREFIX=$(PWD)/target
endif

# Set this on the command line of your make call if needed: make PROXY=host.com:1234
PROXY=




# Select version of chicken, sqlite3 etc
CHICKEN_VERSION=4.9.0.1
SQLITE3_VERSION=3080500
# http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz

# Override IUPBRANCH to use other than trunk
IUPBRANCH=iup-3.10.1

# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
     dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
     json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
     spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \
     srfi-19 refdb ini-file

#
# Derived variables
#

ifeq ($(PROXY),)
PROX:=
else
http_proxy:=http://$(PROXY)
PROX:=-proxy $(PROXY)
endif

BUILDHOME=$(PWD)
PATH:=$(PREFIX)/bin:$(PATH)
LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH)
LD_LIBRARY_PATH=$(LIBPATH)
CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install


︙ ︙ 
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
149
150
151
152
153
154
155
156

157
158
159
160
161
162
163

164

165
166
167
168


169



170


171
172

173
174
175
176
177
178
179
180
181

182
183
184
ISARCHX86_64=$(shell uname -a | grep x86_64)
ifeq ($(ISARCHX86_64),)
ARCHSIZE=
else
ARCHSIZE=64_
endif

IUPFILES=cd-5.5.1_Linux$(KTYPE)_$(ARCHSIZE)lib.tar.gz im-3.8_Linux$(KTYPE)_$(ARCHSIZE)lib.tar.gz iup-3.6_Linux$(KTYPE)_$(ARCHSIZE)lib.tar.gz
CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g')

CSC_OPTIONS=-I$(PREFIX)/include -L$(CSCLIBS)

all : chkn eggs iup

chkn : $(CHICKEN_INSTALL)

eggs : $(EGGSOFILES)

sqlite3 :  $(CHICKEN_EGG_DIR)/sqlite3.so


iup : $(PREFIX)/lib/libavcall.a $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so



# Silly rule to make installing eggs more makeish, I don't understand why I need the basename
$(CHICKEN_EGG_DIR)/%.so : %.flag
	$(CHICKEN_INSTALL) $(PROX) $(shell basename $*)

$(EGGFLAGS) : # $(CHICKEN_INSTALL)
	mkdir -p eggflags
	touch $(EGGFLAGS)

# some setup stuff
#
setup-chicken4x.sh : $(EGGFLAGS)
	(echo "export PATH=$(PATH)" > setup-chicken4x.sh)
	(echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> setup-chicken4x.sh)
	mkdir -p $(PREFIX)

# Download chicken source
chicken-$(CHICKEN_VERSION).tar.gz : 
	wget http://code.call-cc.org/releases/$(CHICKEN_VERSION)/chicken-$(CHICKEN_VERSION).tar.gz

# NB// Must touch csi.scm since tar puts original date on it and deps are wrong then


chicken-$(CHICKEN_VERSION)/csi.scm : chicken-$(CHICKEN_VERSION).tar.gz
	tar xfvz chicken-$(CHICKEN_VERSION).tar.gz

	touch -c chicken-$(CHICKEN_VERSION)/csi.scm



$(CHICKEN_INSTALL) : chicken-$(CHICKEN_VERSION)/csi.scm setup-chicken4x.sh
	cd chicken-$(CHICKEN_VERSION);make PLATFORM=linux PREFIX=$(PREFIX)
	cd chicken-$(CHICKEN_VERSION);make PLATFORM=linux PREFIX=$(PREFIX) install





sqlite-autoconf-$(SQLITE3_VERSION).tar.gz : 
	wget http://www.sqlite.org/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz

sqlite-autoconf-$(SQLITE3_VERSION) : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz
	tar xfz sqlite-autoconf-$(SQLITE3_VERSION).tar.gz 

$(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION)
	(cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install)

$(CHICKEN_EGG_DIR)/sqlite3.so : $(PREFIX)/bin/sqlite3
	CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3







# Get and install my various utilities that haven't been eggified yet.


opensrc/margs/margs.scm opensrc/dbi/dbi.scm opensrc/qtree/qtree.scm : $(CHICKEN_INSTALL) $(CHICKEN_EGG_DIR)/sqlite3.so














	mkdir -p opensrc
	cd opensrc;if [ ! -e opensrc.fossil ]; then fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil; fi
	cd opensrc;if [ -e dbi/dbi.scm ]; then fossil update; else fossil open opensrc.fossil; fi

$(CHICKEN_EGG_DIR)/dbi.so : opensrc/dbi/dbi.scm 
	cd opensrc/dbi;chicken-install

$(CHICKEN_EGG_DIR)/margs.so : opensrc/margs/margs.scm
	cd opensrc/margs;chicken-install

$(CHICKEN_EGG_DIR)/qtree.so : opensrc/qtree/qtree.scm
	cd opensrc/qtree;chicken-install

# $(CHICKEN_EGG_DIR)/dbi.so # Don't include as requires postgres
mattseggs : $(CHICKEN_EGG_DIR)/margs.so $(CHICKEN_EGG_DIR)/qtree.so

# 
# IUP

#

ffcall.tar.gz :
	wget http://www.kiatoa.com/matt/iup/ffcall.tar.gz 

ffcall/README : ffcall.tar.gz
	tar xfvz ffcall.tar.gz

	touch -c ffcall/README


$(PREFIX)/lib/libavcall.a : ffcall/README
	cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make && make install



$(IUPFILES) :



	wget http://www.kiatoa.com/matt/iup/$@


	cd $(PREFIX)/lib;tar xfvz $(BUILDHOME)/$@
	mv $(PREFIX)/lib/include/* $(PREFIX)/include


$(PREFIX)/lib/libiup.so : $(IUPFILES)
	touch -c $(PREFIX)/lib/libiup.so

$(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so
	$(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup

$(CHICKEN_EGG_DIR)/canvas-draw.so :  $(PREFIX)/lib/libiup.so
	$(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw


clean :
	rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION)







<

>
|

|





|

>
|
>
>


|
|












|
|
|

|
>
>
|
|
>
|
>
>

|
|
|

>
>
>
>
|
|

|
|

|
|

|


>
>
>

>
>
|
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>

<
|

<
<
|
<
|

|
|

<
<
|
<
|
>
|
<
|
|

|
|
>
|
>
|



>
>
|
>
>
>
|
>
>
|
|
>

|
|


|


|
>



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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174

175
176


177

178
179
180
181
182


183

184
185
186

187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
ISARCHX86_64=$(shell uname -a | grep x86_64)
ifeq ($(ISARCHX86_64),)
ARCHSIZE=
else
ARCHSIZE=64_
endif


CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g')
CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS)"
# CSC_OPTIONS=-I$(PREFIX)/include -L$(CSCLIBS)

all : chkn eggs libiup logprobin $(PREFIX)/lib/sqlite3.so $(PREFIX)/bin/hs

chkn : $(CHICKEN_INSTALL)

eggs : $(EGGSOFILES)

libiup : $(PREFIX)/lib/libavcall.a $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so

logprobin : $(PREFIX)/bin/logpro

$(PREFIX)/bin/logpro : $(CHICKEN_EGG_DIR)/regex-literals.so
	$(CHICKEN_INSTALL) logpro

# Silly rule to make installing eggs more makeish, I don't understand why I need the basename
$(CHICKEN_EGG_DIR)/%.so : eggflags/%.flag
	$(CHICKEN_INSTALL) $(PROX) -keep-installed $(shell basename $*)

$(EGGFLAGS) : # $(CHICKEN_INSTALL)
	mkdir -p eggflags
	touch $(EGGFLAGS)

# some setup stuff
#
setup-chicken4x.sh : $(EGGFLAGS)
	(echo "export PATH=$(PATH)" > setup-chicken4x.sh)
	(echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> setup-chicken4x.sh)
	mkdir -p $(PREFIX)

chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz
	tar xfz chicken-$(CHICKEN_VERSION).tar.gz
	ln -sf chicken-$(CHICKEN_VERSION) chicken-core


chicken-4.9.0rc1.tar.gz : 
	wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz

chicken-4.9.0.1.tar.gz :
	wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz

# git clone git://code.call-cc.org/chicken-core
# git clone http://code.call-cc.org/git/chicken-core.git

$(CHICKEN_INSTALL) : chicken-core/chicken.scm setup-chicken4x.sh
	cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX)
	cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) install

#======================================================================
# S Q L I T E 3
#======================================================================

sqlite-autoconf-$(SQLITE3_VERSION).tar.gz :
	wget  http://www.sqlite.org/2014/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz

sqlite-autoconf-$(SQLITE3_VERSION)/config.log : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz
	tar xfz  sqlite-autoconf-$(SQLITE3_VERSION).tar.gz

$(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION)/config.log
	cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install

$(PREFIX)/lib/sqlite3.so : $(PREFIX)/bin/sqlite3
	CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3

#======================================================================
# N  A N O M S G
#======================================================================

nanomsg-0.5-beta.tar.gz :
	wget http://download.nanomsg.org/nanomsg-0.5-beta.tar.gz

nanomsg-0.5-beta/COPYING : nanomsg-0.5-beta.tar.gz
	tar xfvz nanomsg-0.5-beta.tar.gz

$(PREFIX)/bin/nanocat : nanomsg-0.5-beta/COPYING
	cd nanomsg-0.5-beta;./configure --prefix=$(PREFIX);make;make install

$(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat
	CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg

#======================================================================
# M A T T S   U T I L S
#======================================================================

opensrc.fossil :
	fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil

opensrc/histstore/histstore.scm : opensrc.fossil
	mkdir -p opensrc

	cd opensrc;fossil open ../opensrc.fossil



opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(PREFIX)/lib/sqlite3.so 

	cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs

$(PREFIX)/bin/hs : opensrc/histstore/hs 
	cp -f opensrc/histstore/hs $(PREFIX)/bin/hs



#======================================================================

# I U P 
#======================================================================


ffcall.fossil :
	fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil

ffcall/README : ffcall.fossil
	mkdir -p ffcall
	cd ffcall && if [ -e README ];then fossil update; else fossil open ../ffcall.fossil; fi

# NOTE: This worked fine *without* the enable-shared
#
$(PREFIX)/lib/libavcall.a : ffcall/README
	cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make && make install

iuplib.fossil :
	fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil

iup/installall.sh : iuplib.fossil
	mkdir -p iup
	cd iup && if [ -e installall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi

iup/alldone : iup/installall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so
	cd iup && ./makeall.sh

$(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh iup/alldone
	cd iup && ./installall.sh

# $(PREFIX)/lib/libiup.so : iup/iup/alldone
#	touch -c $(PREFIX)/lib/libiup.so

$(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so
	LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup

$(CHICKEN_EGG_DIR)/canvas-draw.so :  $(PREFIX)/lib/libiup.so
	CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw


clean :
	rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION)




Added utils/installck.sh version [7eb094e9b0].













































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
#!/bin/bash

myhome=$(dirname $0)

if [[ $proxy == "" ]]; then 
  echo 'Please set the environment variable "proxy" to host.com:port (e.g. foo.com:1234) to use a proxy'
  echo PROX=""
else
  export http_proxy=http://$proxy
  export PROX="-proxy $proxy"
fi

if [[ -z $PREFIX ]];then
  echo "\$PREFIX variable is required"
  exit
fi

export LD_LIBRARY_NAME=$PREFIX/lib

logname=$(basename $PREFIX)

script -c "make -f $myhome/Makefile_latest.installall all" $logname.log




Modified utils/loadrunner
from [3fad28f85d]
to [ba6e3962e1].

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



#!/bin/bash 



# load=`uptime|awk '{print $10}'|cut -d, -f1`
load=`uptime|perl -pe 's/.*: (\d+.\d+),.*/$1/'`































if which cpucheck > /dev/null;then
    numcpu=`cpucheck|tail -1|awk '{print $6}'`
elif which lscpu > /dev/null;then
    numcpu=`lscpu|grep "CPU.s.:"|awk '{print $2}'`
else
    numcpu=2
fi

# NB// max_load is in units of percent.
#
lperc=`echo "100 * $load / $numcpu"|bc`


if [[ "x$MAX_ALLOWED_LOAD" == "x" ]]; then
  max_load=100
else
  max_load=$MAX_ALLOWED_LOAD
fi




if [[  $lperc -lt $max_load ]];then

  echo "Load acceptable: lperc=$lperc %, max_load=$max_load %, load=$load, numcpu=$numcpu, MAX_ALLOWED_LOAD=$MAX_ALLOWED_LOAD %"
  echo "Starting command: \"$@\""
  nbfake "$@"



else




  # echo "Load too high: lperc=$lperc, max_load=$max_load, waiting two minutes before trying to run command: \"$@\""
  echo "loadrunner $@" | at now + 2 minutes 2> /dev/null
fi





>
>

|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>










|
>
>






>
>
>

>
|
|
|
>
>
>
|
>
>
>
>

|

>
>
>
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
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
#!/bin/bash 

LOADRUNNER=$0

# load=`uptime|awk '{print $10}'|cut -d, -f1`
load=$(uptime|perl -pe 's/.*: (\d+.\d+),.*/$1/')
load2=$(uptime|perl -pe 's/.*: (\d+.\d+), (\d+.\d+),.*/$2/')
# echo "load2=$load2, load=$load"

# Run a job detached from stdin/stdout (i.e. daemonized)
# Launch on remotehost if specified by TARGETHOST
#
function launchjob () {
  # Can't always trust $PWD
  CURRWD=`pwd`
  if [[ $TARGETHOST_LOGF == "" ]]; then
      TARGETHOST_LOGF=NBFAKE-`date +%GWW%V.%u_%T`
  fi
  # echo "#======================================================================"
  # echo "# NBFAKE Running command:"
  # echo "#     \"$*\""
  # echo "#======================================================================"
  
  if [[ $TARGETHOST == ""  ]]; then
    sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > $TARGETHOST_LOGF 2>&1 &"
  else
    ssh -n -f $TARGETHOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > $TARGETHOST_LOGF 2>&1 &\""
  fi
}

function get_delay_time () {
  RANGE=$1
  number=$RANDOM
  let "number %= $RANGE"
  echo $number
}

if which cpucheck > /dev/null;then
    numcpu=`cpucheck|tail -1|awk '{print $6}'`
elif which lscpu > /dev/null;then
    numcpu=`lscpu|grep "CPU.s.:"|awk '{print $2}'`
else
    numcpu=2
fi

# NB// max_load is in units of percent.
#
lperc=$(echo "100 * $load / $numcpu"|bc)
lperc2=$(echo "100 * $load2 / $numcpu"|bc)
let "lperc2adj=$lperc2 + $numcpu"
if [[ "x$MAX_ALLOWED_LOAD" == "x" ]]; then
  max_load=100
else
  max_load=$MAX_ALLOWED_LOAD
fi

lfile=/tmp/loadrunner-$USER.lockfile
lockfile -r 5 -l 60 $lfile &> /dev/null

if [[  $lperc -lt $max_load ]];then
  if [[ $lperc -le $lperc2adj ]];then
    # echo "Load acceptable: lperc=$lperc %, max_load=$max_load %, load=$load, numcpu=$numcpu, MAX_ALLOWED_LOAD=$MAX_ALLOWED_LOAD % and $lperc2 < $lperc"
    # echo "Starting command: \"$@\""
    launchjob "$@"
    # we sleep ten seconds here to keep the lock a little longer and give time for
    # the uptime to show a response
    # sleep 2
  else
   echo "$LOADRUNNER $@" | at now + 2 minutes &> /dev/null
   # sleep 5
  fi
else
  # echo "Load too high: lperc=$lperc, max_load=$max_load, waiting two minutes before trying to run command: \"$@\""
  echo "$LOADRUNNER $@" | at now + 2 minutes &> /dev/null
fi

sleep $(get_delay_time 3)
rm -f $lfile




Added utils/loadrunner.scm.notfinished version [a8651ba3f3].

































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192

;; Copyright 2006-2013, 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.

(use ssax)
(use sxml-serializer)
(use sxml-modifications)
(use regex)
(use srfi-69)
(use regex-case)
(use posix)
(use json)
(use csv)
(use srfi-18)
(use format)

(require-library iup)
(import (prefix iup iup:))
(require-library ini-file)
(import (prefix ini-file ini:))

(use canvas-draw)
(import canvas-draw-iup)

(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))

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

;;
;; GLOBALS
;;
(define *loadrunner:current-tab-number* 0)
(define loadrunner:unrecognised-command "ERROR: Unrecognised command or missing params. Try \"loadrunner help\"")
(define loadrunner:help (conc "Usage: loadrunner [action [params ...]]

Note: run loadrunner without parameters to start the gui.

  run cmd [params ..]   : Run cmd params ... when system load drops
  process               : Process the queue

Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest

Version: " megatest-fossil-hash)) ;; "

;;======================================================================
;; DB
;;======================================================================

(define (loadrunner:initialize-db db)
  (for-each
   (lambda (qry)
     (sqlite3:execute db qry))
   (list 
    "CREATE TABLE pkgs 
         (id        INTEGER PRIMARY KEY,
          cmd       TEXT,
          datetime  TEXT);")))

;; Create the sqlite db
(define (loadrunner:open-db path) 
  (if (and path
	   (directory? path)
	   (file-read-access? path))
      (let* ((dbpath    (conc path "/loadrunner.db"))
	     (writeable (file-write-access? dbpath))
	     (dbexists  (file-exists? dbpath))
	     (handler   (make-busy-timeout 136000)))
	(handle-exceptions
	 exn
	 (begin
	   (debug:print 2 "ERROR: problem accessing db " dbpath
			((condition-property-accessor 'exn 'message) exn))
	   (exit))
	 (set! db (sqlite3:open-database dbpath)))
	(if *db-write-access* (sqlite3:set-busy-handler! db handler))
	(if (not dbexists)
	    (begin
	      (loadrunner:initialize-db db)))
	db)))

;;======================================================================
;; GUI
;;======================================================================

;; The main menu 
(define (loadrunner:main-menu)
  (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
   (iup:menu-item "Files" (iup:menu   ;; Note that you can use either #:action or action: for options
		       (iup:menu-item "Open"  action: (lambda (obj)
							(iup:show (iup:file-dialog))
							(print "File->open " obj)))
		       (iup:menu-item "Save"  #:action (lambda (obj)(print "File->save " obj)))
		       (iup:menu-item "Exit"  #:action (lambda (obj)(exit)))))
   (iup:menu-item "Tools" (iup:menu
		       (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
		       ;; (iup:menu-item "Show dialog"     #:action (lambda (obj)
		       ;;  					   (show message-window
		       ;;  					     #:modal? #t
		       ;;  					     ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
		       ;;  					     ;; #:x 'mouse
		       ;;  					     ;; #:y 'mouse
		       ;;  )					     
		       ))))

(define (loadrunner:publish-view)
  (iup:vbox
   (iup:hbox 
    (iup:button "Pushme" 
		#:expand "YES"
		))))

(define (loadrunner:get-view)
  (iup:vbox
   (iup:hbox 
    (iup:button "Pushme"
		#:expand "YES"
		))))

(define (loadrunner:manage-view)
  (iup:vbox
   (iup:hbox 
    (iup:button "Pushme"
		#:expand "YES"
		))))

(define (loadrunner:gui)
  (iup:show
   (iup:dialog 
    #:title (conc "Loadrunner dashboard " (current-user-name) ":" (current-directory))
    #:menu (loadrunner:main-menu)
    (let* ((tabs (iup:tabs
		  #:tabchangepos-cb (lambda (obj curr prev)
				      (set! *loadrunner:current-tab-number* curr))
		  (loadrunner:publish-view)
		  (loadrunner:get-view)
		  (loadrunner:manage-view)
		  )))
	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
	(iup:attribute-set! tabs "TABTITLE0" "Publish")
	(iup:attribute-set! tabs "TABTITLE1" "Get")
	(iup:attribute-set! tabs "TABTITLE2" "Manage")
	;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190")
	tabs)))
  (iup:main-loop))

;;======================================================================
;; MAIN
;;======================================================================

(define (loadrunner:load-config path)
  (let ((fname (conc path "/.loadrunner.config")))
    (ini:property-separator-patt " *  *")
    (ini:property-separator #\space)
    (if (file-exists? fname)
	(ini:read fname)
	'())))

(define (main)
  (let* ((args (argv))
	 (prog (car args))
	 (rema (cdr args))
	 (conf (loadrunner:load-config (pathname-directory prog))))
    ;; (    ?????
    (cond
     ((eq? (length rema) 1)
      (case (string->symbol (car rema))
	((process)(loadrunner:process-queue))
	((pause)
	 (loadrunner:pause-queue (cdr rema)))
	((help -h -help --h --help)
	 (print loadrunner:help))
	(else
	 (print loadrunner:unrecognised-command))))
     ((null? rema)(loadrunner:gui))
     ((>= (length rema) 2)
      (case (string->symbol (car rema))
	((run)
	 (loadrunner:process-cmd (cdr rema)))
	((remove)
	 (loadrunner:remove-cmds (cdr rema)))
	(else
	 (print loadrunner:unrecognised-command))))
     (else (print loadrunner:unrecognised-command)))))

(main)




Modified utils/mk_wrapper
from [8168084a10]
to [8a8fb062fe].

1
2
3
4

5
6
7

8




9




10
11
12
13


14
15
16
#!/bin/bash

prefix=$1
cmd=$2


echo "#!/bin/bash"
if [ "$LD_LIBRARY_PATH" != "" ];then

  echo "INFO: Using LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >&2




  echo "export LD_LIBRARY_PATH=$LD_LIBRARY_PATH"




else
  echo "INFO: LD_LIBRARY_PATH not set" >&2
fi



fullcmd="exec $prefix/bin/$cmd"

echo "$fullcmd \"\$@\""




>

<

>

>
>
>
>
|
>
>
>
>




>
>
|

<
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

#!/bin/bash

prefix=$1
cmd=$2
target=$3


if [ "$LD_LIBRARY_PATH" != "" ];then
  cfgfile="$prefix/bin/.$(lsb_release -sr)/cfg.sh"
  echo "INFO: Using LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >&2
( cat << __EOF
if [ "\$LD_LIBRARY_PATH" != "" ];then
  export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH
else
  export LD_LIBRARY_PATH=$LD_LIBRARY_PATH
fi
__EOF
) > $cfgfile
  echo 
else
  echo "INFO: LD_LIBRARY_PATH not set" >&2
fi

echo "#!/bin/bash" > $target
echo "source $prefix/bin/.\$(lsb_release -sr)/cfg.sh" >> $target
echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target






Modified utils/nbfake
from [455975d5ec]
to [9de79bbac2].

1

2







3


4
















5
6
7




8

































9
10

11
12
#!/bin/bash









# ssh localhost "nohup $* > nbfake.log 2> nbfake.err < /dev/null"



















# Can't always trust $PWD
CURRWD=`pwd`





if [[ $TARGETHOST == ""  ]]; then

































  sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > NBFAKE-`date +%GWW%V.%u_%T` 2>&1 &"
else

  ssh -n -f $TARGETHOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > NBFAKE-`date +%GWW%V.%u_%T` 2>&1 &\""
fi

>
|
>
>
>
>
>
>
>
|
>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|

>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|

>
|

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
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
#!/bin/bash
###############################################################################
#
# nbfake - capture command output in a logfile
#
# nbfake behavior can be changed by setting the following env vars:
#   NBFAKE_HOST       SSH to $NBFAKE_HOST and run command
#   NBFAKE_LOG        Logfile for nbfake output
#
###############################################################################

if [[ -z "$@" ]]; then
  cat <<__EOF

nbfake usage:

nbfake <command to run>

nbfake behavior can be changed by setting the following env vars:
   NBFAKE_HOST       SSH to \$NBFAKE_HOST and run command
   NBFAKE_LOG        Logfile for nbfake output

__EOF
  exit
fi

#==============================================================================
# Setup
#==============================================================================

# Can't always trust $PWD
CURRWD=$(pwd)

# Make sure nbfake host and logfile are set. Fall back to old-style variable names

if [[ -z "$NBFAKE_HOST" && -n "$TARGETHOST" ]]; then 
  MY_NBFAKE_HOST=$TARGETHOST     
  unset TARGETHOST
else
  MY_NBFAKE_HOST=$NBFAKE_HOST
  unset NBFAKE_HOST
fi


if [[ -z "$NBFAKE_LOG" && -n "$TARGETHOST_LOGF" ]]; then 
  MY_NBFAKE_LOG=$TARGETHOST_LOGF
  unset TARGETHOST_LOGF
else
  MY_NBFAKE_LOG=$NBFAKE_LOG
  unset NBFAKE_LOG
fi

# Set default nbfake log

if [[ -z "$MY_NBFAKE_LOG" ]]; then
  MY_NBFAKE_LOG=NBFAKE-$(date +%GWW%V.%u_%T)
fi

#==============================================================================
# Run and log
#==============================================================================

cat <<__EOF >&2
#======================================================================
# NBFAKE logging command to: $MY_NBFAKE_LOG
#     $*
#======================================================================
__EOF

if [[ -z "$MY_NBFAKE_HOST" ]]; then
  # Run locally
  sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &"
else
  # run remotely
  ssh -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &\""
fi




Modified utils/plot-code.scm
from [de4d05b676]
to [cd37a2db38].

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
#!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq








(use regex srfi-69 srfi-13)

(define targs #f) 
(define files (cddddr (argv)))

(let ((targdat (cadddr (argv))))
  (if (equal? targdat "-")
      (set! targs files)
      (set! targs (string-split targdat ","))))

(define filedat-defns (make-hash-table))
(define filedat-usages (make-hash-table))

(define defn-rx (regexp "^\\s*\\(define\\s+\\(([^\\s\\)]+).*"))
(define all-regexs (make-hash-table))

(define all-fns '())



(define (print-err . data)
  (with-output-to-port (current-error-port)
    (lambda ()
      (apply print data))))

(print-err "Making graph for files: " (string-intersperse targs ", "))


>
>
>
>
>
>
>

















>
>







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
#!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq

;; Coming soon (right?) Usage: plot-code file1.scm,file2.scm "fun1,fun2,x*" *.scm > plot.dot
;; Usage: plot-code file1.scm,file2.scm *.scm > plot.dot
;;        dot -Tpdf plot.dot > plot.pdf
;; first param is comma separated list of files to include in the map, use - to do all
;; second param is list of regexs for functions to include in the map
;; third param is list of files to scan

(use regex srfi-69 srfi-13)

(define targs #f) 
(define files (cddddr (argv)))

(let ((targdat (cadddr (argv))))
  (if (equal? targdat "-")
      (set! targs files)
      (set! targs (string-split targdat ","))))

(define filedat-defns (make-hash-table))
(define filedat-usages (make-hash-table))

(define defn-rx (regexp "^\\s*\\(define\\s+\\(([^\\s\\)]+).*"))
(define all-regexs (make-hash-table))

(define all-fns '())

;; for the se

(define (print-err . data)
  (with-output-to-port (current-error-port)
    (lambda ()
      (apply print data))))

(print-err "Making graph for files: " (string-intersperse targs ", "))


︙ ︙ 
79
80
81
82
83
84
85
86





















87
88
89
90
91
92
93
		    (loop (car tal)
			  (cdr tal)
			  newres)))
	      (if (null? tal)
		  res
		  (loop (car tal)(cdr tal) res)))))
      '()))
  





















;; Gather the usages
(print "digraph G {")
(define curr-cluster-num 0)
(define function-calls '())

(for-each
 (lambda (fname)







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







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
		    (loop (car tal)
			  (cdr tal)
			  newres)))
	      (if (null? tal)
		  res
		  (loop (car tal)(cdr tal) res)))))
      '()))

;; (define mm-header #<<MMHEADER
;; <map version="freeplane 1.2.0">
;; <!--To view this file, download free mind mapping software Freeplane from http://freeplane.sourceforge.net -->
;; 
;; MMHEADER
;; 
;; (define (add-node text)
;;   <node TEXT="homenode" ID="ID_1723255651" CREATED="1283093380553" MODIFIED="1417113442955"><hook NAME="MapStyle">
;; )
;; 
;;  minimal mindmap file
;;  <map version="freeplane 1.2.0">
;;   <!--To view this file, download free mind mapping software Freeplane from http://freeplane.sourceforge.net -->
;;   <node TEXT="homenode" ID="ID_1723255651" CREATED="1283093380553" MODIFIED="1417113442955">
;;   <node TEXT="node1" POSITION="right" ID="ID_1810107939" CREATED="1417113473476" MODIFIED="1417113480425">
;;   <node TEXT="node2" ID="ID_68133256" CREATED="1417113482134" MODIFIED="1417113484466"/>
;;   <node TEXT="node3" ID="ID_1572284821" CREATED="1417113487785" MODIFIED="1417113491589"/>
;;   </node>
;;   </node>
;;   </map>

;; Gather the usages
(print "digraph G {")
(define curr-cluster-num 0)
(define function-calls '())

(for-each
 (lambda (fname)


︙ ︙ 



Added utils/trace/trace.import.scm version [937dcb55c1].

































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;;; trace.import.scm - GENERATED BY CHICKEN 4.9.0.1 -*- Scheme -*-

(eval '(import
         scheme
         chicken
         csi
         advice
         extras
         ports
         data-structures
         (except srfi-1 break)
         miscmacros))
(##sys#register-compiled-module
  'trace
  (list)
  '((breakpoint . trace#breakpoint)
    (trace . trace#trace)
    (untrace . trace#untrace)
    (break . trace#break)
    (unbreak . trace#unbreak)
    (trace-output-port . trace#trace-output-port)
    (continue . trace#continue)
    (c . trace#c)
    (traced? . trace#traced?)
    (trace-module . trace#trace-module)
    (untrace-module . trace#untrace-module)
    (trace-verbose . trace#trace-verbose)
    (trace/untrace . trace#trace/untrace))
  (list)
  (list))

;; END OF FILE




Added utils/trace/trace.meta version [9714181a62].





















>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
;;;; trace.meta -*- Scheme -*-


((category tools)
 (synopsis "tracing and breakpoints")
 (author "felix winkelmann")
 (license "public domain")
 (needs advice				; don't we all?
	miscmacros)
 (files "tests/run.scm" "trace.meta" "trace.release-info" "trace.scm" "trace.setup") )




Added utils/trace/trace.scm version [dc3560e035].







































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
;;;; trace.scm


(module trace (breakpoint 
	       trace untrace
	       break unbreak
	       trace-output-port
	       continue c 
	       traced?
	       trace-module untrace-module
	       trace-verbose
	       trace/untrace)
	       
(import scheme chicken csi)

(use advice extras ports data-structures)
(require-library srfi-1)
(import (except srfi-1 break) miscmacros)


(define *last-breakpoint* #f)
(define *traced-procedures* '())
(define *broken-procedures* '())
(define *trace-indent-level* 0)

(define trace-output-port (make-parameter (current-output-port)))
(define trace-verbose (make-parameter #t))

(define (break-entry name args)
  ;; Does _not_ unwind!
  (##sys#call-with-current-continuation
   (lambda (c)
     (let ((exn (##sys#make-structure
		 'condition
		 '(exn breakpoint)
		 (list '(exn . message) "*** breakpoint ***"
		       '(exn . arguments) (list (cons name args))
		       '(exn . location) name
		       '(exn . continuation) c) ) ) )
       (set! *last-breakpoint* exn)
       (signal exn) ) ) ) )

(define (break-resume exn)
  (let ((a (member '(exn . continuation) (##sys#slot exn 2))))
    (if a
	((cadr a) (void))
	(error "condition has no continuation" exn) ) ) )

(define (breakpoint #!optional (name 'breakpoint))
  (break-entry name '()) )

(define (trace-indent)
  (let ((port (trace-output-port)))
    (do ((i (fxmin 3 *trace-indent-level*) (fx- i 1)))
	((fx<= i 0))
      (write-char #\space port) )
    (fprintf port "[~a] " *trace-indent-level*) ) )

(define (traced-procedure-entry name args)
  (let ((port (trace-output-port)))
    (trace-indent)
    (set! *trace-indent-level* (fx+ 1 *trace-indent-level*))
    (write (cons name args) port)
    (write ", Called from: " port)
    (write (conc (car (reverse (get-call-chain)))))
    (write-char #\newline port)
    (flush-output port) ) )

(define (traced-procedure-exit name results)
  (let ((port (trace-output-port)))
    (set! *trace-indent-level* (fx- *trace-indent-level* 1))
    (trace-indent)
    (fprintf port "~a -> " name)
    (if results
	(for-each
	 (lambda (x)
	   (write x port)
	   (write-char #\space port) )
	 results)
	(display "(escaping)" port))
    (write-char #\newline port)
    (flush-output port) ) )

(define (procedure-name proc)
  (cond ((procedure-information proc) =>
	 (lambda (info)
	   (if (pair? info) (car info) info) ) )
	(else '<unknown>)) )

(define (do-trace procs)
  (for-each
   (lambda (s)
     (ensure procedure? s)
     (cond ((traced? s)
	    (warning "procedure already traced" s) )
	   (else
	    (let ((name (procedure-name s)))
	      (when (trace-verbose)
		(fprintf (current-error-port) "; tracing ~a~%" name))
	      (set! *traced-procedures* (cons (cons s name) *traced-procedures*))
	      (advise 
	       'around s
	       (lambda (next args)
		 (let ((results #f))
		   (dynamic-wind
		       (cut traced-procedure-entry name args)
		       (lambda () 
			 (call-with-values (cut apply next args)
			   (lambda rs
			     (set! results rs)
			     (apply values rs))))
		       (cut traced-procedure-exit name results))))
	       '*trace*)))))
   procs) )

(define (do-untrace-all)
  (define (unadvise* p)
    (ignore-errors (unadvise p '*trace*)))
  (for-each
   (lambda (proc)
     (let ((proc (car proc)))
       (when (trace-verbose)
	 (fprintf (current-error-port) "; untracing ~a~%" (procedure-name proc))
	 (unadvise* proc))))
   *traced-procedures*)
  (set! *traced-procedures* '()))

(define (do-untrace procs)
  (for-each
   (lambda (s)
     (ensure procedure? s)
     (let ((p (assq s *traced-procedures*)) 
	   (name (procedure-name s)))
       (cond ((not p) (warning "procedure not traced" name))
	     (else
	      (when (trace-verbose)
		(fprintf (current-error-port) "; untracing ~a~%" name))
	      (ignore-errors (unadvise s '*trace*))
	      (set! *traced-procedures* 
		(delete 
		 p *traced-procedures* 
		 eq?))))))
   procs) )

(define (do-break procs)
  (for-each
   (lambda (s)
     (let ((name (procedure-name s)))
       (ensure procedure? s)
       (cond ((assq s *broken-procedures*)
	      (warning "procedure already has break-point" name))
	     (else
	      (when (trace-verbose)
		(fprintf (current-error-port) "; setting break-point in ~a~%" name))
	      (set! *broken-procedures* (cons (cons s name) *broken-procedures*))
	      (advise 
	       'before s
	       (lambda (args)
		 (break-entry name args) )
	       '*break*) ) )))
   procs) )

(define (do-unbreak procs)
  (for-each
   (lambda (s)
     (ensure procedure? s)
     (let ((p (assq s *broken-procedures*)) 
	   (name (procedure-name s)))
       (cond ((not p) (warning "procedure has no breakpoint" name))
	     (else
	      (when (trace-verbose)
		(fprintf (current-error-port) "; removing break-point in ~a~%" name))
	      (ignore-errors (unadvise s '*break*))
	      (set! *broken-procedures* (delete p *broken-procedures* eq?) ) ) ) ) )
   procs) )

(define (do-unbreak-all)
  (for-each
   (lambda (bp)
     (ignore-errors (unadvise (car bp) '*break*)))
   *broken-procedures*)
  (set! *broken-procedures* '())
  (void))

(define (trace . procs)
  (cond ((null? procs)
	 (when (pair? *traced-procedures*)
	   (printf "Traced:~%~%")
	   (for-each (lambda (p) (printf "  ~a~%" (cdr p))) *traced-procedures*)) )
	(else
	 (do-trace procs) ) ) )

(define (untrace . procs)
  (cond ((null? procs) (do-untrace-all))
	(else (do-untrace procs)))
  (void))

(define (break . procs)
  (cond ((null? procs)
	 (when (pair? *broken-procedures*)
	   (printf "Breakpoints:~%~%")
	   (for-each (lambda (p) (printf "  ~a~%" (cdr p))) *broken-procedures*)) )
	(else
	 (do-break procs) ) ) )

(define (unbreak . procs)
  (cond ((null? procs) (do-unbreak-all))
	(else (do-unbreak procs))))

(define (continue #!optional (bp *last-breakpoint*))
  (cond (*last-breakpoint*
	 (let ((exn *last-breakpoint*))
	   (set! *last-breakpoint* #f)
	   (break-resume exn) ) )
	(else (display "no breakpoint pending\n") ) ) )

(define c continue)

(define (traced? proc)
  (assq proc *traced-procedures*))

(define (trace/untrace . procs)
  (for-each
   (lambda (proc)
     ((if (traced? proc) do-untrace do-trace) (list proc)))
   procs))

(define (walk-module mname proc)
  (let* ((m (##sys#find-module mname))
	 (exps (nth-value 1 (##sys#module-exports m))))
    (for-each
     (lambda (exp)
       (let* ((realname (cdr exp))
	      (prim (get realname '##core#primitive)))
	 (if prim
	     (warning "export is a core-library primitive - not traced" (car exp))
	     (when (##sys#symbol-has-toplevel-binding? realname)
	       (let ((val (##sys#slot realname 0)))
		 (when (procedure? val)
		   (proc val)))))))
     exps)))

(define (trace-module . mnames)
  (for-each
   (lambda (mname)
     (walk-module mname trace))
   mnames))

(define (untrace-module . mnames)
  (for-each
   (lambda (mname)
     (walk-module 
      mname 
      (lambda (proc)
	(when (traced? proc)
	  (do-untrace (list proc))))))
   mnames))

)




Added utils/trace/trace.setup version [d222d610b4].



















>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
;;;; trace.setup -*- Scheme -*-


(compile -s trace.scm -O3 -d1 -j trace)
(compile -s trace.import.scm -O3 -d0)

(install-extension
 'trace
 '("trace.so" "trace.import.so"))




Added widgets.scm version [3d56925ea9].



























































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
(require-library srfi-4 iup)
(import srfi-4 iup iup-pplot iup-glcanvas) ;; iup-web

(define (popup dlg . args)
  (apply show dlg #:modal? 'yes args)
  (destroy! dlg))

(define (properties ih)
  (popup (element-properties-dialog ih))
  'default)

(define dlg
  (dialog
    (vbox
      (hbox ; headline
        (fill)
        (frame (label " Inspect control and dialog classes "
                      fontsize: 15))
        (fill)
        margin: '0x0)

      (label "") 
      (label "Dialogs" fontsize: 12)
      (hbox
        (button "dialog"
                action: (lambda (self) (properties (dialog (vbox)))))
        (button "color-dialog"
                action: (lambda (self) (properties (color-dialog))))
        (button "file-dialog"
                action: (lambda (self) (properties (file-dialog))))
        (button "font-dialog"
                action: (lambda (self) (properties (font-dialog))))
        (button "message-dialog"
                action: (lambda (self) (properties (message-dialog))))
        (fill)
        margin: '0x0)
      (hbox
        (button "layout-dialog"
                action: (lambda (self) (properties (layout-dialog))))
        (button "element-properties-dialog"
                action: (lambda (self)
                          (properties
                            (element-properties-dialog (create 'user)))))
        (fill)
        margin: '0x0)

      (label "") 
      (label "Composition widgets" fontsize: 12)
      (hbox
        (button "fill"
                action: (lambda (self) (properties (fill))))
        (button "hbox"
                action: (lambda (self) (properties (hbox))))
        (button "vbox"
                action: (lambda (self) (properties (vbox))))
        (button "zbox"
                action: (lambda (self) (properties (zbox))))
        (button "radio"
                action: (lambda (self) (properties (radio (vbox)))))
        (button "normalizer"
                action: (lambda (self) (properties (normalizer))))
        (button "cbox"
                action: (lambda (self) (properties (cbox))))
        (button "sbox"
                action: (lambda (self) (properties (sbox (vbox)))))
        (button "split"
                action: (lambda (self) (properties (split (vbox) (vbox)))))
        (fill)
        margin: '0x0)

      (label "") 
      (label "Standard widgets" fontsize: 12)
      (hbox
        (button "button"
                action: (lambda (self) (properties (button))))
        (button "canvas"
                action: (lambda (self) (properties (canvas))))
        (button "frame"
                action: (lambda (self) (properties (frame))))
        (button "label"
                action: (lambda (self) (properties (label))))
        (button "listbox"
                action: (lambda (self) (properties (listbox))))
        (button "progress-bar"
                action: (lambda (self) (properties (progress-bar))))
        (button "spin"
                action: (lambda (self) (properties (spin))))
        (fill)
        margin: '0x0)
      (hbox
        (button "tabs"
                action: (lambda (self) (properties (tabs))))
        (button "textbox"
                action: (lambda (self) (properties (textbox))))
        (button "toggle"
                action: (lambda (self) (properties (toggle))))
        (button "treebox"
                action: (lambda (self) (properties (treebox))))
        (button "valuator"
                action: (lambda (self) (properties (valuator ""))))
        (fill)
        margin: '0x0)

      (label "") 
      (label "Additional widgets" fontsize: 12)
      (hbox
        (button "cells"
                action: (lambda (self) (properties (cells))))
        (button "color-bar"
                action: (lambda (self) (properties (color-bar))))
        (button "color-browser"
                action: (lambda (self) (properties (color-browser))))
        (button "dial"
                action: (lambda (self) (properties (dial ""))))
        (button "matrix"
                action: (lambda (self) (properties (matrix))))
        (fill)
        margin: '0x0)
      (hbox
        (button "pplot"
                action: (lambda (self) (properties (pplot))))
        (button "glcanvas"
                action: (lambda (self) (properties (glcanvas))))
        ;; (button "web-browser"
        ;;         action: (lambda (self) (properties (web-browser))))
        (fill)
        margin: '0x0)

      (label "") 
      (label "Menu widgets" fontsize: 12)
      (hbox
        (button "menu"
                action: (lambda (self) (properties (menu))))
        (button "menu-item"
                action: (lambda (self) (properties (menu-item))))
        (button "menu-separator"
                action: (lambda (self) (properties (menu-separator))))
        (fill)
        margin: '0x0)

      (label "") 
      (label "Images" fontsize: 12)
      (hbox
        (button "image/palette"
                action: (lambda (self)
                          (properties
                            (image/palette 1 1 (u8vector->blob (u8vector 0))))))
        (button "image/rgb"
                action: (lambda (self)
                          (properties
                            (image/rgb 1 1 (u8vector->blob (u8vector 0))))))
        (button "image/rgba"
                action: (lambda (self)
                          (properties
                            (image/rgba 1 1 (u8vector->blob (u8vector 0))))))
        (button "image/file"
                action: (lambda (self)
                          (properties
                            ;; same attributes as image/palette
                            (image/palette 1 1 (u8vector->blob (u8vector 0))))))
                            ;; needs a file in current directory
                            ;(image/file "chicken.ico")))) ; ok
                            ;(image/file "chicken.png")))) ; doesn't work
        (fill)
        margin: '0x0)

      (label "") 
      (label "Other widgets" fontsize: 12)
      (hbox
        (button "clipboard"
                action: (lambda (self) (properties (clipboard))))
        (button "timer"
                action: (lambda (self) (properties (timer))))
        (button "spinbox"
                action: (lambda (self) (properties (spinbox (vbox)))))
        (fill)
        margin: '0x0)

      (fill)
      (button "E&xit"
              expand: 'horizontal
              action: (lambda (self) 'close))
      )
    margin: '15x15
    title: "Iup inspector"))

(show dlg)
(main-loop)
(exit 0)

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 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	# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ ~~http-transport.scm filedb.scm \~~ client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ tree.scm ezsteps.scm lock-queue.scm sdb.scm \ ~~rmt.scm api.scm tdb.scm rpc-transport.scm~~ GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) ADTLSCR=mt_laststep mt_runstep mt_ezstep HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR)) DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR)) MTESTHASH=$(shell fossil info\|grep checkout:\| awk '{print $$2}') CSIPATH=$(shell which csi) CKPATH=$(shell dirname $(shell dirname $(CSIPATH))) ~~all : mtest ~~dboard new~~dboard txtdb~~ refdb : txtdb/txtdb.scm csc -I txtdb txtdb/txtdb.scm -o refdb mtest: $(OFILES) megatest.o csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm csc $(OFILES) dashboard.scm $(GOFILES) -o dboard ~~newdboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(OFILES) $(GOFILES) newdashboard.scm -o newdboard~~ $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl ~~deploytarg/libiupcd.so : $(CKPATH)/lib/libiupcd.so~~ ~~for i in iup im cd av call sqlite; do \~~ ~~cp $(CKPATH)/lib/lib$$i* deploytarg/ ; \~~ ~~done~~ ~~cp $(CKPATH)/include/*.h deploytarg~~ ~~# puts deployed megatest in directory "megatest"~~ ~~deploytarg/megatest : $(OFILES) megatest.o~~ ~~csc -deploy $(CSCOPTS) $(OFILES) megatest.scm~~ ~~rsync -av megatest/ deploytarg/~~ ~~deploytarg/dashboard : $(OFILES) $(GOFILES)~~ ~~csc -deploy $(OFILES) $(GOFILES) dashboard.scm~~ ~~rsync -av dashboard/ deploytarg/~~ # Special dependencies for the includes tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o megatest.o : db_records.scm tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm	\| \| > > > > > > > > > > > > \| \| \| > \| \| < < < < < < < < < < < < < < < <	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 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	# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm nmsg-transport.scm filedb.scm \ client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ tree.scm ezsteps.scm lock-queue.scm sdb.scm \ rmt.scm api.scm tdb.scm rpc-transport.scm \ portlogger.scm # Eggs to install (straightforward ones) EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3 GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) ADTLSCR=mt_laststep mt_runstep mt_ezstep HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR)) DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR)) MTESTHASH=$(shell fossil info\|grep checkout:\| awk '{print $$2}') CSIPATH=$(shell which csi) CKPATH=$(shell dirname $(shell dirname $(CSIPATH))) # ARCHSTR=$(shell uname -m)_$(shell uname -r) # BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE") # ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr) ARCHSTR=$(shell lsb_release -sr) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard txtdb refdb : txtdb/txtdb.scm csc -I txtdb txtdb/txtdb.scm -o refdb mtest: $(OFILES) megatest.o csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm csc $(OFILES) dashboard.scm $(GOFILES) -o dboard ndboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(OFILES) $(GOFILES) newdashboard.scm -o ndboard # # $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm # csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl # Special dependencies for the includes tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o megatest.o : db_records.scm tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm
︙			︙
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	if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi $(OFILES) $(GOFILES) : common_records.scm %.o : %.scm csc $(CSCOPTS) -c $< ~~$(PREFIX)/bin/mtest : mtest~~ @echo Installing to PREFIX=$(PREFIX) ~~$(INSTALL) mtest $(PREFIX)/bin/mtest utils/mk_wrapper $(PREFIX) mtest > $(PREFIX)/bin/megatest~~ chmod a+x $(PREFIX)/bin/megatest ~~$(PREFIX)/bin/~~new~~dboard : newdboard $(INSTALL) newdboard $(PREFIX)/bin/~~new~~dboard~~ ~~utils/mk_wrapper $(PREFIX) newdboard > $(PREFIX)/bin/newdashboard~~ chmod a+x $(PREFIX)/bin/newdashboard $(HELPERS) : utils/mt_* $(INSTALL) $< $@ chmod a+x $@ ~~$(DEPLOYHELPERS) : utils/mt_* ~~$(INSTALL) $< $@~~ ~~chmod a+X $@~~~~ $(PREFIX)/bin/mt_xterm : utils/mt_xterm $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/nbfake : utils/nbfake $(INSTALL) $< $@ chmod a+x $@	\| \| \| \| \| > > \| < < < <	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	if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi $(OFILES) $(GOFILES) : common_records.scm %.o : %.scm csc $(CSCOPTS) -c $< $(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest @echo Installing to PREFIX=$(PREFIX) $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest chmod a+x $(PREFIX)/bin/megatest $(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard $(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard chmod a+x $(PREFIX)/bin/newdashboard $(HELPERS) : utils/mt_* $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/mt_xterm : utils/mt_xterm $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/nbfake : utils/nbfake $(INSTALL) $< $@ chmod a+x $@
︙			︙
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 149 150 151~~ 152 153 154 155 156 157	deploytarg/nbfind : utils/nbfind $(INSTALL) $< $@ chmod a+x $@ # install dashboard as dboard so wrapper script can be called dashboard ~~$(PREFIX)/bin/dboard : dboard $(FILES) ~~$(INSTALL) dboard $(PREFIX)/bin/dboard~~ utils/mk_wrapper $(PREFIX) dboard > $(PREFIX)/bin/dashboard~~ chmod a+x $(PREFIX)/bin/dashboard ~~install~~ ~~: bin~~ $(PREFIX)/bin/~~mtest~~ $(PR~~EFIX~~)~~/bin/megatest $(PREFIX)/bin~~/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/~~newdboard $(PREFIX)/bin/~~refdb $(PREFIX)/bin/mt_xterm ~~$(PREFIX)/bin/revtagfsl~~ ~~deploytarg/apropos.so : Makefile~~ for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \ ~~chicken-install -prefix deploytarg -deploy $$i;done~~ ~~deploytarg/libsqlite3.so :~~ ~~CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3~~ ~~deploy : deploytarg/megatest deploytarg/dashboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/nbfind deploytarg/libiupcd.so deploytarg/apropos.so~~ ~~bin :~~ mkdir -p $(PREFIX)/bin test: tests/tests.scm cd tests;csi -I .. -b -n tests.scm clean : rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o	\| < \| > > \| \| \| < < < < < \| < < < < < < \| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > >	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 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186	deploytarg/nbfind : utils/nbfind $(INSTALL) $< $@ chmod a+x $@ # install dashboard as dboard so wrapper script can be called dashboard $(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard chmod a+x $(PREFIX)/bin/dashboard $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/refdb $(PREFIX)/bin/mt_xterm \ $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) test: tests/tests.scm cd tests;csi -I .. -b -n tests.scm clean : rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o # Deploy section (not complete yet) # $(DEPLOYHELPERS) : utils/mt_* $(INSTALL) $< $@ chmod a+X $@ deploytarg/apropos.so : Makefile chicken-install -p deploytarg -deploy $(EGGS) # for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \ # chicken-install -prefix deploytarg -deploy $$i;done # deploytarg/libsqlite3.so : # CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3 deploy : deploytarg/mtest deploytarg/dboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/nbfind deploytarg/apropos.so # deploytarg/libiupcd.so : $(CKPATH)/lib/libiupcd.so # for i in iup im cd av call sqlite; do \ # cp $(CKPATH)/lib/lib$$i* deploytarg/ ; \ # done # cp $(CKPATH)/include/*.h deploytarg # puts deployed megatest in directory "megatest" deploytarg/mtest : $(OFILES) megatest.o deploytarg/apropos.so csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg mv deploytarg/deploytarg deploytarg/mtest deploytarg/dboard : $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg mv deploytarg/deploytarg deploytarg/dboard # DATASHAREO=configf.o common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \ # megatest-version.o tdb.o ods.o mt.o keys.o datashare-testing/sd : datashare.scm $(OFILES) csc datashare.scm $(OFILES) -o datashare-testing/sd sd : datashare-testing/sd mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath xterm : sd (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &)

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19	;;====================================================================== ;; 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. ;;====================================================================== ~~(use sqlite3 srfi-1 posix regex-case base64 format dot-locking csv-xml)~~ (require-extension sqlite3 regex posix) (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:))	\|	1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19	;;====================================================================== ;; 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. ;;====================================================================== (use sqlite3 srfi-1 posix regex-case base64 format dot-locking csv-xml z3) (require-extension sqlite3 regex posix) (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:))
︙			︙
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	(define configdat #f) (define toppath #f) (define already-seen-runconfig-info #f) (define waiting-queue (make-hash-table)) (define test-meta-updated (make-hash-table)) (define globalexitstatus 0) ;; attempt to work around possible thread issues (define passnum 0) ;; when running track calls to run-tests or similar ;; DATABASE ~~(define ~~open-~~dbs ~~(vector #f~~ (make-hash-table))) ;; ~~megate~~stdb ~~run-id-dbs~~~~ ;; SERVER (define my-client-signature #f) ~~(define transport-type #f) (define ~~meg~~a~~tes~~t-db ~~#f)~~ ~~(define rpc:listener #f) ;; if set up for server communication this will hold the tcp port~~~~ (define runremote (make-hash-table)) ;; if set up for server communication this will hold <host port> ~~(define last-db-access (current-seconds)) ;; update when db is accessed via server~~ (define max-cache-size 0) (define logged-in-clients (make-hash-table)) (define client-non-blocking-mode #f) (define server-id #f) (define server-info #f) (define time-to-exit #f) (define received-response #f) (define default-numtries 10) (define server-run #t) ~~(define db-write-access #t)~~ ~~(define inmemdb #f)~~ (define run-id #f) (define server-kind-run (make-hash-table)) (define target (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN (define keys (make-hash-table)) ;; cache the keys here (define keyvals (make-hash-table)) (define toptest-paths (make-hash-table)) ;; cache toptest path settings here	> > > > > > > > \| > > > > > > > \| \| < < < <	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	(define configdat #f) (define toppath #f) (define already-seen-runconfig-info #f) (define waiting-queue (make-hash-table)) (define test-meta-updated (make-hash-table)) (define globalexitstatus 0) ;; attempt to work around possible thread issues (define passnum 0) ;; when running track calls to run-tests or similar (define write-frequency (make-hash-table)) ;; run-id => (vector (current-seconds) 0)) (define alt-log-file #f) ;; used by -log (define common:denoise (make-hash-table)) ;; for low noise printing ;; DATABASE (define dbstruct-db #f) (define db-stats (make-hash-table)) ;; hash of vectors < count duration-total > (define db-stats-mutex (make-mutex)) (define db-sync-mutex (make-mutex)) (define db-multi-sync-mutex (make-mutex)) (define db-local-sync (make-hash-table)) ;; used to record last touch of db (define megatest-db #f) (define last-db-access (current-seconds)) ;; update when db is accessed via server (define db-write-access #t) (define inmemdb #f) (define task-db #f) ;; (vector db path-to-db) (define db-access-allowed #t) ;; flag to allow access (define db-access-mutex (make-mutex)) ;; SERVER (define my-client-signature #f) (define transport-type 'http) (define transport-type 'http) ;; override with [server] transport http\|rpc\|nmsg (define runremote (make-hash-table)) ;; if set up for server communication this will hold <host port> (define max-cache-size 0) (define logged-in-clients (make-hash-table)) (define client-non-blocking-mode #f) (define server-id #f) (define server-info #f) (define time-to-exit #f) (define received-response #f) (define default-numtries 10) (define server-run #t) (define run-id #f) (define server-kind-run (make-hash-table)) (define target (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN (define keys (make-hash-table)) ;; cache the keys here (define keyvals (make-hash-table)) (define toptest-paths (make-hash-table)) ;; cache toptest path settings here
︙			︙
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	(set! test-paths (make-hash-table)) (set! test-ids (make-hash-table)) (set! test-info (make-hash-table)) (set! run-info-cache (make-hash-table)) (set! env-vars-by-run-id (make-hash-table)) (set! test-id-cache (make-hash-table))) ~~;; Generic string database ~~(normalization of sorts)~~~~ (define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f) ~~;; Generic path database ~~(normalization of sorts)~~~~ (define fdb #f) ;;====================================================================== ;; U S E F U L S T U F F ;;====================================================================== (define (common:get-megatest-exe) (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest")) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== (define common:std-states '((0 "COMPLETED") (1 "NOT_STARTED")	\| \| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > >	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 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176	(set! test-paths (make-hash-table)) (set! test-ids (make-hash-table)) (set! test-info (make-hash-table)) (set! run-info-cache (make-hash-table)) (set! env-vars-by-run-id (make-hash-table)) (set! test-id-cache (make-hash-table))) ;; Generic string database (define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f) ;; Generic path database (define fdb #f) ;;====================================================================== ;; L O C K E R S A N D B L O C K E R S ;;====================================================================== ;; block further accesses to databases. Call this before shutting db down (define (common:db-block-further-queries) (mutex-lock! db-access-mutex) (set! db-access-allowed #f) (mutex-unlock! db-access-mutex)) (define (common:db-access-allowed?) (let ((val (begin (mutex-lock! db-access-mutex) db-access-allowed (mutex-unlock! db-access-mutex)))) val)) ;;====================================================================== ;; U S E F U L S T U F F ;;====================================================================== (define (common:low-noise-print waitval . keys) (let* ((key (string-intersperse (map conc keys) "-" )) (lasttime (hash-table-ref/default common:denoise key 0)) (currtime (current-seconds))) (if (> (- currtime lasttime) waitval) (begin (hash-table-set! common:denoise key currtime) #t) #f))) (define (common:get-megatest-exe) (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest")) (define (common:read-encoded-string instr) (handle-exceptions exn (handle-exceptions exn (begin (debug:print 0 "ERROR: received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) #f) (read (open-input-string (base64:base64-decode instr)))) (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== (define common:std-states '((0 "COMPLETED") (1 "NOT_STARTED")
︙			︙
157 158 159 160 161 162 163 164 165 166 167 168 169 170	(let ((val (args:get-arg val))) (if val val default))) (define (assoc/default key lst . default) (let ((res (assoc key lst))) (if res (cadr res)(if (null? default) #f (car default))))) ;;====================================================================== ;; Misc utils ;;====================================================================== ;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 (define (common:hms-string->seconds tstr) (let ((parts (string-split tstr))	> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > >	207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259	(let ((val (args:get-arg val))) (if val val default))) (define (assoc/default key lst . default) (let ((res (assoc key lst))) (if res (cadr res)(if (null? default) #f (car default))))) (define (common:get-testsuite-name) (or (configf:lookup configdat "setup" "testsuite" ) (pathname-file toppath))) ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (std-exit-procedure) (debug:print-info 2 "starting exit process, finalizing databases.") (rmt:print-db-stats) (let ((run-ids (hash-table-keys db-local-sync))) (if (and (not (null? run-ids)) (configf:lookup configdat "setup" "megatest-db")) (db:multi-db-sync run-ids 'new2old))) (if dbstruct-db (db:close-all dbstruct-db)) (if inmemdb (db:close-all inmemdb)) (if (and megatest-db (sqlite3:database? megatest-db)) (begin (sqlite3:interrupt! megatest-db) (sqlite3:finalize! megatest-db #t) (set! megatest-db #f))) (if task-db (let ((db (cdr task-db))) (if (sqlite3:database? db) (begin (sqlite3:interrupt! db) (sqlite3:finalize! db #t) (vector-set! task-db 0 #f)))))) (define (std-signal-handler signum) (signal-mask! signum) (debug:print 0 "ERROR: Received signal " signum " exiting promptly") ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway (exit)) (set-signal-handler! signal/int std-signal-handler) (set-signal-handler! signal/term std-signal-handler) ;;====================================================================== ;; Misc utils ;;====================================================================== ;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 (define (common:hms-string->seconds tstr) (let ((parts (string-split tstr))
︙			︙
222 223 224 225 226 227 228 ~~229~~ 230 ~~231 232~~ 233 234 ~~235~~ 236 ~~237~~ 238 239 240 241 242 243 244 245	(if (string-match (regexp modpatt) item) (set! res #t)))) (string-split patts ",")) res) #t)) ;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) ~~(define (common:get-runconfig-targets)~~ (sort (map car (hash-table->alist ~~(read-config "runconfigs.config" #f #t))) ~~string<?)~~)~~ ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' ~~(define (common:get-disks)~~ (hash-table-ref/default ~~(read-config "megatest.config" #f #t)~~ "disks" '("none" ""))) ;;====================================================================== ;; M I S C L I S T S ;;====================================================================== ;; items in lista are matched value and position in listb ;; return the remaining items in listb or #f	\| > \| \| > \| \| > > > > > > > > > > > > > > > > > > > > > > > > >	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	(if (string-match (regexp modpatt) item) (set! res #t)))) (string-split patts ",")) res) #t)) ;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) (define (common:get-runconfig-targets #!key (configf #f)) (sort (map car (hash-table->alist (or configf (read-config "runconfigs.config" #f #t)))) string<?)) ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks #!key (configf #f)) (hash-table-ref/default (or configf (read-config "megatest.config" #f #t)) "disks" '("none" ""))) ;;====================================================================== ;; T A R G E T S ;;====================================================================== (define (common:args-get-target #!key (split #f)) (let* ((target (if (args:get-arg "-reqtarg") (args:get-arg "-reqtarg") (if (args:get-arg "-target") (args:get-arg "-target") (getenv "MT_TARGET")))) (tlist (if target (string-split target "/" #t) '())) (valid (if target (and (not (null? tlist)) (null? (filter string-null? tlist))) #f))) (if valid (if split tlist target) (if target (begin (debug:print 0 "ERROR: Invalid target, spaces or blanks not allowed \"" target "\"") #f) #f)))) ;;====================================================================== ;; M I S C L I S T S ;;====================================================================== ;; items in lista are matched value and position in listb ;; return the remaining items in listb or #f
︙			︙
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 ~~365~~ 366 367 368 369 ~~370 371 372 373~~ ~~374~~ ~~375~~ 376 377 ~~378 379 380 381~~ ~~382~~ 383 384 385 386 387 388 389	(let ((newval (string->number (cadr match)))) (if (number? newval) (set! freespc newval)))))) (car df-results)) freespc)) (define (get-cpu-load) (let* ((load-res (cmd-run->list "uptime")) (load-rx (regexp "load average:\\s+(\\d+)")) (cpu-load #f)) (for-each (lambda (l) (let ((match (string-search load-rx l))) (if match (let ((newval (string->number (cadr match)))) (if (number? newval) (set! cpu-load newval)))))) (car load-res)) cpu-load)) (define (get-uname . params) (let* ((uname-res (cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) (uname #f)) (if (null? (car uname-res)) "unknown" (caar uname-res)))) ~~(define (save-environment-as-files fname #!key (ignorevars (list "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR")))~~ (let ((envvars (get-environment-variables)) (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]"))) (with-output-to-file (conc fname ".csh") (lambda () ~~(for-each (lambda (key) (if (~~not~~ (~~membe~~r key ~~ignorevars~~)) ~~(let* (~~(val (cdr key)) (~~sval~~ (if (string-search whitesp val)~~(conc "\"" val "\"") val)))~~~~ ~~~~(print~~ "setenv " ~~(car key) " " sval)))~~)~~ ~~envvars)))~~ (with-output-to-file (conc fname ".sh") (lambda () ~~(for-each (lambda (key) (if (~~not~~ (~~membe~~r key ~~ignorevars~~)) ~~(let* (~~(val (cdr key)) (~~sval~~ (if (string-search whitesp val)~~(conc "\"" val "\"") val)))~~~~ ~~~~(print~~ "export " ~~(car key) "=" sval)))~~)~~ envvars))))) ;; set some env vars from an alist, return an alist with original values ;; (("VAR" "value") ...) (define (alist->env-vars lst) (if (list? lst) (let ((res '()))	> \| \| \| \| \| \| \| \| \| \| \| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > \| \| \| \| \| > > > > \| > \| \| \| \| \| > > > > \| >	455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552	(let ((newval (string->number (cadr match)))) (if (number? newval) (set! freespc newval)))))) (car df-results)) freespc)) (define (get-cpu-load) (car (common:get-cpu-load))) ;; (let* ((load-res (cmd-run->list "uptime")) ;; (load-rx (regexp "load average:\\s+(\\d+)")) ;; (cpu-load #f)) ;; (for-each (lambda (l) ;; (let ((match (string-search load-rx l))) ;; (if match ;; (let ((newval (string->number (cadr match)))) ;; (if (number? newval) ;; (set! cpu-load newval)))))) ;; (car load-res)) ;; cpu-load)) ;; get cpu load by reading from /proc/loadavg, return all three values ;; (define (common:get-cpu-load) (with-input-from-file "/proc/loadavg" (lambda ()(list (read)(read)(read))))) (define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000)) (let* ((loadavg (common:get-cpu-load)) (first (car loadavg)) (next (cadr loadavg)) (adjload (* maxload numcpus)) (loadjmp (- first next))) (cond ((and (> first adjload) (> count 0)) (debug:print-info 0 "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload) (thread-sleep! waitdelay) (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))) ((and (> loadjmp numcpus) (> count 0)) (debug:print-info 0 "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus) (thread-sleep! waitdelay) (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))))) (define (common:get-num-cpus) (with-input-from-file "/proc/cpuinfo" (lambda () (let loop ((numcpu 0) (inl (read-line))) (if (eof-object? inl) numcpu (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl) (+ numcpu 1) numcpu) (read-line))))))) (define (get-uname . params) (let* ((uname-res (cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) (uname #f)) (if (null? (car uname-res)) "unknown" (caar uname-res)))) (define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF"))) (let ((envvars (get-environment-variables)) (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]"))) (with-output-to-file (conc fname ".csh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) (delim (if (string-search whitesp val) "\"" ""))) (print (if (member key ignorevars) "# setenv " "setenv ") key " " delim val delim))) envvars))) (with-output-to-file (conc fname ".sh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) (delim (if (string-search whitesp val) "\"" ""))) (print (if (member key ignorevars) "# export " "export ") key "=" delim val delim))) envvars))))) ;; set some env vars from an alist, return an alist with original values ;; (("VAR" "value") ...) (define (alist->env-vars lst) (if (list? lst) (let ((res '()))
︙			︙
426 427 428 429 430 431 432 433 434 435 436 437 438 439	(define (seconds->year-work-week/day sec) (time->string (seconds->local-time sec) "%yww%V.%w")) (define (seconds->year-work-week/day-time sec) (time->string (seconds->local-time sec) "%yww%V.%w %H:%M")) ;;====================================================================== ;; Colors ;;====================================================================== (define (common:name->iup-color name) (case (string->symbol (string-downcase name))	> > > > > > > > > > >	589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613	(define (seconds->year-work-week/day sec) (time->string (seconds->local-time sec) "%yww%V.%w")) (define (seconds->year-work-week/day-time sec) (time->string (seconds->local-time sec) "%yww%V.%w %H:%M")) (define (seconds->quarter sec) (case (string->number (time->string (seconds->local-time sec) "%m")) ((1 2 3) 1) ((4 5 6) 2) ((7 8 9) 3) ((10 11 12) 4) (else #f))) ;;====================================================================== ;; Colors ;;====================================================================== (define (common:name->iup-color name) (case (string->symbol (string-downcase name))
︙			︙

︙			︙
59 60 61 62 63 64 65 66 67 68 69 70 71 72 73	(define configf:key-no-val (regexp "^(\\S+)(\\s)$")) (define configf:comment-rx (regexp "^\\s#.")) (define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.)$")) ;; read a line and process any #{ ... } constructs (define configf:var-expand-regex (regexp "^(.)#\\{(scheme\|system\|shell\|getenv\|get\|runconfigs-get\|rget)\\s+([^\\}\\{])\\}(.)")) ~~(define (configf:process-line l ht)~~ (let loop ((res l)) (if (string? res) (let ((matchdat (string-search configf:var-expand-regex res))) (if matchdat (let ((prestr (list-ref matchdat 1)) (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv (cmd (list-ref matchdat 3))	\|	59 60 61 62 63 64 65 66 67 68 69 70 71 72 73	(define configf:key-no-val (regexp "^(\\S+)(\\s)$")) (define configf:comment-rx (regexp "^\\s#.")) (define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.)$")) ;; read a line and process any #{ ... } constructs (define configf:var-expand-regex (regexp "^(.)#\\{(scheme\|system\|shell\|getenv\|get\|runconfigs-get\|rget)\\s+([^\\}\\{])\\}(.)")) (define (configf:process-line l ht allow-system) (let loop ((res l)) (if (string? res) (let ((matchdat (string-search configf:var-expand-regex res))) (if matchdat (let ((prestr (list-ref matchdat 1)) (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv (cmd (list-ref matchdat 3))
︙			︙
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	(sect (car parts)) (var (cadr parts))) (conc "(lambda (ht)(config-lookup ht \"" sect "\" \"" var "\"))"))) ((runconfigs-get) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))) ;; (print "fullcmd=" fullcmd) ~~(with-input-from-string fullcmd (lambda () (set! result ((eval (read)) ht)))) (loop (conc prestr result poststr)))~~ res)) res))) ;; Run a shell command and return the output as a string (define (shell cmd) (let* ((output (cmd-run->list cmd)) (res (car output)) (status (cadr output))) (if (equal? status 0) (let ((outres (string-intersperse res "\n"))) (debug:print-info 4 "shell result:\n" outres) outres) (begin (with-output-to-port (current-error-port) ~~(print "ERROR: " cmd " returned bad exit code " status))~~ "")))) ;; Lookup a value in runconfigs based on -reqtarg or -target (define (runconfigs-get config var) ~~(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))~~ (if targ (or (configf:lookup config targ var) (configf:lookup config "default" var)) (configf:lookup config "default" var)))) ~~(define~~-inline~~ (configf:read-line p ht allow-processing)~~ (let loop ((inl (read-line p))) (let ((cont-line (and (string? inl) (not (string-null? inl)) (equal? "\\" (string-take-right inl 1))))) (if cont-line ;; last character is \ (let ((nextl (read-line p))) (if (not (eof-object? nextl)) (loop (string-append (if cont-line (string-take inl (- (string-length inl) 1)) inl) nextl)))) ~~(if (and allow-processing (not (eq? allow-processing 'return-string)))~~ ~~(configf:process-line inl ht)~~ ~~~~inl))))~~)~~ ;; read a config file, returns hash table of alists ;; read a config file, returns hash table of alists ;; adds to ht if given (must be #f otherwise) ;; envion-patt is a regex spec that identifies sections that will be eval'd ;; in the environment on the fly	> > \| \| \| \| > \| \| > > \| \| \| > \| > \| > >	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 149 150 151 152	(sect (car parts)) (var (cadr parts))) (conc "(lambda (ht)(config-lookup ht \"" sect "\" \"" var "\"))"))) ((runconfigs-get) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))) ;; (print "fullcmd=" fullcmd) (if (or allow-system (not (member cmdtype '("system" "shell")))) (with-input-from-string fullcmd (lambda () (set! result ((eval (read)) ht)))) (set! result (conc "#{(" cmdtype ") " cmd "}"))) (loop (conc prestr result poststr))) res)) res))) ;; Run a shell command and return the output as a string (define (shell cmd) (let* ((output (cmd-run->list cmd)) (res (car output)) (status (cadr output))) (if (equal? status 0) (let ((outres (string-intersperse res "\n"))) (debug:print-info 4 "shell result:\n" outres) outres) (begin (with-output-to-port (current-error-port) (lambda () (print "ERROR: " cmd " returned bad exit code " status))) "")))) ;; Lookup a value in runconfigs based on -reqtarg or -target (define (runconfigs-get config var) (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET")))) (if targ (or (configf:lookup config targ var) (configf:lookup config "default" var)) (configf:lookup config "default" var)))) ;; this was inline but I'm pretty sure that is a hold over from when it was very simple ... ;; (define (configf:read-line p ht allow-processing) (let loop ((inl (read-line p))) (let ((cont-line (and (string? inl) (not (string-null? inl)) (equal? "\\" (string-take-right inl 1))))) (if cont-line ;; last character is \ (let ((nextl (read-line p))) (if (not (eof-object? nextl)) (loop (string-append (if cont-line (string-take inl (- (string-length inl) 1)) inl) nextl)))) (case allow-processing ;; if (and allow-processing ;; (not (eq? allow-processing 'return-string))) ((#t #f) (configf:process-line inl ht allow-processing)) ((return-string) inl) (else (configf:process-line inl ht allow-processing))))))) ;; read a config file, returns hash table of alists ;; read a config file, returns hash table of alists ;; adds to ht if given (must be #f otherwise) ;; envion-patt is a regex spec that identifies sections that will be eval'd ;; in the environment on the fly
︙			︙
267 268 269 270 271 272 273 274 275 276 277 278 279 280	(if match ;; (and match (list? match)(> (length match) 1)) (cadr match) #f)) )) #f)) (define configf:lookup config-lookup) (define (configf:section-vars cfgdat section) (let ((sectdat (hash-table-ref/default cfgdat section '()))) (if (null? sectdat) '() (map car sectdat))))	>	276 277 278 279 280 281 282 283 284 285 286 287 288 289 290	(if match ;; (and match (list? match)(> (length match) 1)) (cadr match) #f)) )) #f)) (define configf:lookup config-lookup) (define configf:read-file read-config) (define (configf:section-vars cfgdat section) (let ((sectdat (hash-table-ref/default cfgdat section '()))) (if (null? sectdat) '() (map car sectdat))))
︙			︙
337 338 339 340 341 342 343 ~~344~~ 345 346 347 348 349 350 351	(let ((inp (open-input-file fname))) (let loop ((inl (read-line inp)) (res '())) (if (eof-object? inl) (begin (close-input-port inp) (reverse res)) ~~(loop (read-line inp)(cons inl)))))~~ '())) ;;====================================================================== ;; Write a config ;; 0. Given a refererence data structure "indat" ;; 1. Open the output file and read it into a list ;; 2. Flatten any multiline entries	\|	347 348 349 350 351 352 353 354 355 356 357 358 359 360 361	(let ((inp (open-input-file fname))) (let loop ((inl (read-line inp)) (res '())) (if (eof-object? inl) (begin (close-input-port inp) (reverse res)) (loop (read-line inp)(cons inl res))))) '())) ;;====================================================================== ;; Write a config ;; 0. Given a refererence data structure "indat" ;; 1. Open the output file and read it into a list ;; 2. Flatten any multiline entries
︙			︙
425 426 427 428 429 430 431	(with-output-to-file fname (lambda () (for-each (lambda (line) (print line)) (configf:expand-multi-lines fdat))))))	> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > >	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 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494	(with-output-to-file fname (lambda () (for-each (lambda (line) (print line)) (configf:expand-multi-lines fdat)))))) ;;====================================================================== ;; refdb ;;====================================================================== ;; reads a refdb into an assoc array of assoc arrays ;; returns (list dat msg) (define (configf:read-refdb refdb-path) (let ((sheets-file (conc refdb-path "/sheet-names.cfg"))) (if (not (file-exists? sheets-file)) (list #f (conc "ERROR: no refdb found at " refdb-path)) (if (not (file-read-access? sheets-file)) (list #f (conc "ERROR: refdb file not readable at " refdb-path)) (let* ((sheets (with-input-from-file sheets-file (lambda () (let loop ((inl (read-line)) (res '())) (if (eof-object? inl) (reverse res) (loop (read-line)(cons inl res))))))) (data '())) (for-each (lambda (sheet-name) (let* ((dat-path (conc refdb-path "/" sheet-name ".dat")) (ref-dat (configf:read-file dat-path #f #t)) (ref-assoc (map (lambda (key) (list key (hash-table-ref ref-dat key))) (hash-table-keys ref-dat)))) ;; (hash-table->alist ref-dat))) (set! data (append data (list (list sheet-name ref-assoc)))))) sheets) (list data "NO ERRORS")))))) ;; map over all pairs in a three level hierarchial alist and apply a function to the keys/val ;; (define (configf:map-all-hier-alist data proc #!key (initproc1 #f)(initproc2 #f)(initproc3 #f)) (for-each (lambda (sheetname) (let* ((sheettmp (assoc sheetname data)) (sheetdat (if sheettmp (cadr sheettmp) '()))) (if initproc1 (initproc1 sheetname)) (for-each (lambda (sectionname) (let* ((sectiontmp (assoc sectionname sheetdat)) (sectiondat (if sectiontmp (cadr sectiontmp) '()))) (if initproc2 (initproc2 sheetname sectionname)) (for-each (lambda (varname) (let* ((valtmp (assoc varname sectiondat)) (val (if valtmp (cadr valtmp) ""))) (proc sheetname sectionname varname val))) (map car sectiondat)))) (map car sheetdat)))) (map car data)))

︙			︙
30 31 32 33 34 35 36 37 38 39 40 41 42 43	(declare (uses ezsteps)) ;; (declare (uses sdb)) ;; (declare (uses filedb)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (define (test-info-panel testdat store-label widgets) (iup:frame #:title "Test Info" ; #:expand "YES" (iup:hbox ; #:expand "YES" (apply iup:vbox ; #:expand "YES" (append (map (lambda (val)	> > > > > > > > > > > > > > >	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	(declare (uses ezsteps)) ;; (declare (uses sdb)) ;; (declare (uses filedb)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") ;;====================================================================== ;; C O M M O N ;;====================================================================== (define dashboard-comment-share-slot #f) (define (dtests:get-pre-command #!key (default-override #f)) (let ((cfg-ovrd (configf:lookup configdat "dashboard" "pre-command"))) (or cfg-ovrd default-override "xterm -geometry 180x20 -e \""))) (define (dtests:get-post-command #!key (default-override #f)) (let ((cfg-ovrd (configf:lookup configdat "dashboard" "post-command"))) (or cfg-ovrd default-override ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) (define (test-info-panel testdat store-label widgets) (iup:frame #:title "Test Info" ; #:expand "YES" (iup:hbox ; #:expand "YES" (apply iup:vbox ; #:expand "YES" (append (map (lambda (val)
︙			︙
113 114 115 116 117 118 119 ~~120 121~~ 122 123 124 125 126 127 128	(append (map (lambda (val) (iup:label val ; #:expand "HORIZONTAL" )) (list "Author: " "Owner: " "Reviewed: " "Tags: " ~~"Description: " ))~~ (list (iup:label "" #:expand "VERTICAL")))) (apply iup:vbox ; #:expand "YES" (list (store-meta "author" (iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL") (lambda (testmeta)(db:testmeta-get-author testmeta))) (store-meta "owner"	\| <	128 129 130 131 132 133 134 135 136 137 138 139 140 141 142	(append (map (lambda (val) (iup:label val ; #:expand "HORIZONTAL" )) (list "Author: " "Owner: " "Reviewed: " "Tags: " "Description: ")) (list (iup:label "" #:expand "VERTICAL")))) (apply iup:vbox ; #:expand "YES" (list (store-meta "author" (iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL") (lambda (testmeta)(db:testmeta-get-author testmeta))) (store-meta "owner"
︙			︙
182 183 184 185 186 187 188 ~~189~~ 190 191 192 193 194 195 196	(iup:label val ; #:expand "HORIZONTAL" )) (list "Hostname: " "Uname -a: " "Disk free: " "CPU Load: " "Run duration: " ~~"Logfile: "))~~ (iup:label "" #:expand "VERTICAL"))) (apply iup:vbox ; #:expand "YES" (list ;; NOTE: Yes, the host can change! (store-label "HostName" (iup:label ;; (sdb:qry 'getstr (db:test-get-host testdat) ;; )	\| >	196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211	(iup:label val ; #:expand "HORIZONTAL" )) (list "Hostname: " "Uname -a: " "Disk free: " "CPU Load: " "Run duration: " "Logfile: " "Top process id: ")) (iup:label "" #:expand "VERTICAL"))) (apply iup:vbox ; #:expand "YES" (list ;; NOTE: Yes, the host can change! (store-label "HostName" (iup:label ;; (sdb:qry 'getstr (db:test-get-host testdat) ;; )
︙			︙
205 206 207 208 209 210 211 ~~212~~ 213 ~~214~~ 215 216 217 218 219 220 221	(lambda (testdat)(conc (db:test-get-diskfree testdat)))) (store-label "CPULoad" (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL") (lambda (testdat)(conc (db:test-get-cpuload testdat)))) (store-label "RunDuration" (iup:label (conc (seconds->hr-min-sec (db:test-get-run_duration testdat))) #:expand "HORIZONTAL") (lambda (testdat)(conc (seconds->hr-min-sec (db:test-get-run_duration testdat))))) ~~(store-label "~~CPU~~Load"~~ (iup:label (conc (db:test-get-final_logf testdat)) #:expand "HORIZONTAL") ~~(lambda (testdat)(conc (db:test-get-final_logf testdat))))~~)))))~~~~ ;; use a global for setting the buttons colors ;; state status teststeps (define state-status (vector #f #f #f)) (define (update-state-status-buttons testdat) (let* ((state (db:test-get-state testdat)) (status (db:test-get-status testdat))	\| \| > > > >	220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240	(lambda (testdat)(conc (db:test-get-diskfree testdat)))) (store-label "CPULoad" (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL") (lambda (testdat)(conc (db:test-get-cpuload testdat)))) (store-label "RunDuration" (iup:label (conc (seconds->hr-min-sec (db:test-get-run_duration testdat))) #:expand "HORIZONTAL") (lambda (testdat)(conc (seconds->hr-min-sec (db:test-get-run_duration testdat))))) (store-label "LogFile" (iup:label (conc (db:test-get-final_logf testdat)) #:expand "HORIZONTAL") (lambda (testdat)(conc (db:test-get-final_logf testdat)))) (store-label "ProcessId" (iup:label (conc (db:test-get-process_id testdat)) #:expand "HORIZONTAL") (lambda (testdat)(conc (db:test-get-process_id testdat)))) ))))) ;; use a global for setting the buttons colors ;; state status teststeps (define state-status (vector #f #f #f)) (define (update-state-status-buttons testdat) (let* ((state (db:test-get-state testdat)) (status (db:test-get-status testdat))
︙			︙
272 273 274 275 276 277 278 ~~279~~ 280 281 282 283 284 285 286	(iup:label "STATUS:" #:size "30x") (let* ((btns (map (lambda (status) (let ((btn (iup:button status #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) (let ((t (iup:attribute x "TITLE"))) (if (equal? t "WAIVED") ~~(iup:show (dashboard-tests:waiver testdat~~ (if wtxtbox (iup:attribute wtxtbox "VALUE") #f) (lambda (c) (set! newcomment c) (if wtxtbox (begin (iup:attribute-set! wtxtbox "VALUE" c) (if (not dashboard-comment-share-slot)	\|	291 292 293 294 295 296 297 298 299 300 301 302 303 304 305	(iup:label "STATUS:" #:size "30x") (let* ((btns (map (lambda (status) (let ((btn (iup:button status #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) (let ((t (iup:attribute x "TITLE"))) (if (equal? t "WAIVED") (iup:show (dashboard-tests:waiver run-id testdat (if wtxtbox (iup:attribute wtxtbox "VALUE") #f) (lambda (c) (set! newcomment c) (if wtxtbox (begin (iup:attribute-set! wtxtbox "VALUE" c) (if (not dashboard-comment-share-slot)
︙			︙
332 333 334 335 336 337 338 ~~339~~ 340 341 342 343 344 345 346	(conc "ezstep run from step " stepname))))) ;; (iup:button "Refresh test data" ;; #:expand "HORIZONTAL" ;; #:action (lambda (obj) ;; (print "Refresh test data " stepname)) ))) ~~(define (dashboard-tests:waiver testdat ovrdval cmtcmd)~~ (let* ((wpatt (configf:lookup configdat "setup" "waivercommentpatt")) (wregx (if (string? wpatt)(regexp wpatt) #f)) (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) (comnt (iup:textbox #:action (lambda (val a b) (if wpatt (if (string-match wregx b) (iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt))	\|	351 352 353 354 355 356 357 358 359 360 361 362 363 364 365	(conc "ezstep run from step " stepname))))) ;; (iup:button "Refresh test data" ;; #:expand "HORIZONTAL" ;; #:action (lambda (obj) ;; (print "Refresh test data " stepname)) ))) (define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd) (let* ((wpatt (configf:lookup configdat "setup" "waivercommentpatt")) (wregx (if (string? wpatt)(regexp wpatt) #f)) (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) (comnt (iup:textbox #:action (lambda (val a b) (if wpatt (if (string-match wregx b) (iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt))
︙			︙
374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 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 462 463 464 465 466 467 468 469~~ 470 471 472 473 ~~474 475~~ 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 ~~494~~ 495 ~~496~~ 497 498 499 500 501 502 503	(iup:destroy! dlog)))))) (iup:button "Cancel" #:expand "HORIZONTAL" #:action (lambda (obj) (iup:destroy! dlog))))))) dlog)) ~~;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!!~~ ;; ~~;; get a pretty table to summarize steps~~ ;; ~~(define (dashboard-tests:process-steps-table steps);; db test-id #!key (work-area #f))~~ ~~;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area)))~~ ~~;; organise the steps for better readability~~ ~~(let ((res (make-hash-table)))~~ ~~(for-each~~ ~~(lambda (step)~~ ~~(debug:print 6 "step=" step)~~ ~~(let ((record (hash-table-ref/default~~ ~~res~~ ~~(tdb:step-get-stepname step)~~ ~~;; stepname start end status Duration Logfile~~ ~~(vector (tdb:step-get-stepname step) "" "" "" "" ""))))~~ ~~(debug:print 6 "record(before) = " record~~ ~~"\nid: " (tdb:step-get-id step)~~ ~~"\nstepname: " (tdb:step-get-stepname step)~~ ~~"\nstate: " (tdb:step-get-state step)~~ ~~"\nstatus: " (tdb:step-get-status step)~~ ~~"\ntime: " (tdb:step-get-event_time step))~~ ~~(case (string->symbol (tdb:step-get-state step))~~ ~~((start)(vector-set! record 1 (tdb:step-get-event_time step))~~ ~~(vector-set! record 3 (if (equal? (vector-ref record 3) "")~~ ~~(tdb:step-get-status step)))~~ ~~(if (> (string-length (tdb:step-get-logfile step))~~ 0) ~~(vector-set! record 5 (tdb:step-get-logfile step))))~~ ~~((end)~~ ~~(vector-set! record 2 (any->number (tdb:step-get-event_time step)))~~ ~~(vector-set! record 3 (tdb:step-get-status step))~~ ~~(vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))~~ ~~(endt (any->number (vector-ref record 2))))~~ ~~(debug:print 4 "record[1]=" (vector-ref record 1)~~ ~~", startt=" startt ", endt=" endt~~ ~~", get-status: " (tdb:step-get-status step))~~ ~~(if (and (number? startt)(number? endt))~~ ~~(seconds->hr-min-sec (- endt startt)) "-1")))~~ ~~(if (> (string-length (tdb:step-get-logfile step))~~ 0) ~~(vector-set! record 5 (tdb:step-get-logfile step))))~~ ~~(else~~ ~~(vector-set! record 2 (tdb:step-get-state step))~~ ~~(vector-set! record 3 (tdb:step-get-status step))~~ ~~(vector-set! record 4 (tdb:step-get-event_time step))))~~ ~~(hash-table-set! res (tdb:step-get-stepname step) record)~~ ~~(debug:print 6 "record(after) = " record~~ ~~"\nid: " (tdb:step-get-id step)~~ ~~"\nstepname: " (tdb:step-get-stepname step)~~ ~~"\nstate: " (tdb:step-get-state step)~~ ~~"\nstatus: " (tdb:step-get-status step)~~ ~~"\ntime: " (tdb:step-get-event_time step))))~~ ~~;; (else (vector-set! record 1 (tdb:step-get-event_time step)))~~ ~~(sort steps (lambda (a b)~~ ~~(cond~~ ~~((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)~~ ~~((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b))~~ ~~(< (tdb:step-get-id a) (tdb:step-get-id b)))~~ ~~(else #f)))))~~ ~~res))~~ ~~(define (dashboard-tests:get-compressed-steps dbstruct run-id test-id)~~ ~~(let* ((steps-data (db:get-steps-for-test dbstruct run-id test-id))~~ ~~(comprsteps (dashboard-tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area)))~~ ~~(map (lambda (x)~~ ~~;; take advantage of the \n on time->string~~ ~~(vector~~ ~~(vector-ref x 0)~~ ~~(let ((s (vector-ref x 1)))~~ ~~(if (number? s)(seconds->time-string s) s))~~ ~~(let ((s (vector-ref x 2)))~~ ~~(if (number? s)(seconds->time-string s) s))~~ ~~(vector-ref x 3) ;; status~~ ~~(vector-ref x 4)~~ ~~(vector-ref x 5))) ;; time delta~~ ~~(sort (hash-table-values comprsteps)~~ ~~(lambda (a b)~~ ~~(let ((time-a (vector-ref a 1))~~ ~~(time-b (vector-ref b 1)))~~ ~~(if (and (number? time-a)(number? time-b))~~ ~~(if (< time-a time-b)~~ #t ~~(if (eq? time-a time-b)~~ ~~(string<? (conc (vector-ref a 2))~~ ~~(conc (vector-ref b 2)))~~ ~~#f))~~ ~~(string<? (conc time-a)(conc time-b)))))))))~~ ;;====================================================================== ;; ;;====================================================================== (define (examine-test run-id test-id) ;; run-id run-key origtest) ~~(let* ((db-path (conc toppath "/db/" run-id ".db")) (dbstruct (make-dbr:dbstruct path: toppath local: #t))~~ (testdat (db:get-test-info-by-id dbstruct run-id test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) (if (not testdat) (begin (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") (exit 1)) (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f)) (keydat (if testdat (db:get-key-val-pairs dbstruct run-id) #f)) (rundat (if testdat (db:get-run-info dbstruct run-id) #f)) (runname (if testdat (db:get-value-by-header (db:get-rows rundat) (db:get-header rundat) "runname") #f)) (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) ;; These next two are intentional bad values to ensure errors if they should not ;; get filled in properly. (logfile "/this/dir/better/not/exist") ~~(rundir ~~log~~f~~ile)~~~~ (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found ~~(teststeps (if testdat (d~~ashb~~o~~ard-tests~~:get-compressed-steps dbstruct run-id test-id) '()))~~ (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) (testmeta (if testdat (let ((tm (db:testmeta-get-record dbstruct testname))) (if tm tm (make-db:testmeta))) (make-db:testmeta)))	< < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < \| \| \| > > \|	393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436	(iup:destroy! dlog)))))) (iup:button "Cancel" #:expand "HORIZONTAL" #:action (lambda (obj) (iup:destroy! dlog))))))) dlog)) ;;====================================================================== ;; ;;====================================================================== (define (examine-test run-id test-id) ;; run-id run-key origtest) (let* ((db-path (db:dbfile-path run-id)) ;; (conc (configf:lookup configdat "setup" "linktree") "/db/" run-id ".db")) (dbstruct (make-dbr:dbstruct path: (configf:lookup configdat "setup" "linktree") local: #t)) (testdat (db:get-test-info-by-id dbstruct run-id test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) (if (not testdat) (begin (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") (exit 1)) (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f)) (keydat (if testdat (db:get-key-val-pairs dbstruct run-id) #f)) (rundat (if testdat (db:get-run-info dbstruct run-id) #f)) (runname (if testdat (db:get-value-by-header (db:get-rows rundat) (db:get-header rundat) "runname") #f)) (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) ;; These next two are intentional bad values to ensure errors if they should not ;; get filled in properly. (logfile "/this/dir/better/not/exist") (rundir (if testdat (db:test-get-rundir testdat) logfile)) (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found (teststeps (if testdat (dcommon:get-compressed-steps dbstruct run-id test-id) '())) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) (testmeta (if testdat (let ((tm (db:testmeta-get-record dbstruct testname))) (if tm tm (make-db:testmeta))) (make-db:testmeta)))
︙			︙
540 541 542 543 544 545 546 ~~547~~ 548 549 550 551 552 ~~553~~ 554 555 556 557 558 559 560	(> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched (> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds request-update)) (newtestdat (if need-update ;; NOTE: BUG HIDER, try to eliminate this exception handler (handle-exceptions exn ~~(debug:print-info 0 "test db access issue: " ((condition-property-accessor 'exn 'message) exn))~~ (db:get-test-info-by-id dbstruct run-id test-id ))))) ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) ~~(set! teststeps (d~~ashb~~o~~ard-tests~~:get-compressed-steps dbstruct run-id test-id))~~ (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir ;; (filedb:get-path fdb (db:test-get-rundir testdat)) ;; ) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) ;; I don't see why this was implemented this way. Please comment it ...	\| \|	473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493	(> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched (> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds request-update)) (newtestdat (if need-update ;; NOTE: BUG HIDER, try to eliminate this exception handler (handle-exceptions exn (debug:print-info 0 "test db access issue in examine test for run-id " run-id ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn)) (db:get-test-info-by-id dbstruct run-id test-id ))))) ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) (set! teststeps (dcommon:get-compressed-steps dbstruct run-id test-id)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir ;; (filedb:get-path fdb (db:test-get-rundir testdat)) ;; ) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) ;; I don't see why this was implemented this way. Please comment it ...
︙			︙
605 606 607 608 609 610 611 ~~612~~ ~~613~~ 614 615 616 ~~617~~ 618 ~~619 620~~ 621 622 623 ~~624~~ 625 626 627 ~~628~~ 629 630 631 ~~632~~ 633 634 635 ~~636~~ 637 ~~638 639~~ 640 641 642 ~~643~~ 644 645 646 ~~647~~ ~~648~~ 649 650 651 ~~652~~ 653 654 655 ~~656~~ 657 658 659 660 661 662 663	(iup:attribute-set! lbl "TITLE" newval) ;(mutex-unlock! mx1) ))))) lbl)) (store-button store-label) (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10")) (command-launch-button (iup:button "Execute!" #:action (lambda (x) ~~(let ((cmd (iup:attribute command-text-box "VALUE")))~~ ~~(system ~~(conc~~ cmd ~~" &")~~)))))~~ (kill-jobs (lambda (x) (iup:attribute-set! command-text-box "VALUE" ~~(conc "~~xterm -geometry 180x20 -e \"~~megatest -target " keystring " :runname " runname~~ " -set-state-status KILLREQ,n/a -testpatt %/% " ~~~~;; (conc testname "/" (if (equal? item-path "") "%" item-path))~~ " :state RUNNING ~~;echo Press any key to continue;bash -c 'read -n 1 -s'\"~~"))))~~ (run-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" ~~(conc "~~xterm -geometry 180x20 -e \"~~megatest -target " keystring " :runname " runname~~ " -runtests " (conc testname "/" (if (equal? item-path "") "%" item-path)) ~~~~" ;echo Press any key to continue;bash -c 'read -n 1 -s'\""~~))))~~ (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" ~~(conc "~~xterm -geometry 180x20 -e \"~~megatest -remove-runs -target " keystring " :runname " runname~~ " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) ~~" -v ~~;echo Press any key to continue;bash -c 'read -n 1 -s'\"~~"))))~~ (clean-run-execute (lambda (x) ~~~~(let ((cmd (conc "xterm -geometry 180x20 -e \""~~ "megatest -remove-runs -target " keystring " :runname " runname~~ " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) ~~";megatest -target " keystring " :runname " runname~~ " -runtests " (conc testname "/" (if (equal? item-path "") "%" item-path)) ~~" ;echo Press any key to continue;bash -c 'read -n 1 -s'\"")))~~ ~~(system (conc cm~~d " &"))))~~)~~ (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" ~~(conc "~~xterm -geometry 180x20 -e \"~~megatest -remove-runs -target " keystring " :runname " runname~~ " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) ~~" -v ~~;echo Press any key to continue;bash -c 'read -n 1 -s'\"~~"))~~ ))) (cond ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1))) ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) (else ;; (test-set-status! db run-id test-name state status itemdat) (set! self ;	\| > > > > \| \| < \| \| \| \| \| < \| \| < > \| > > \| \|	538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600	(iup:attribute-set! lbl "TITLE" newval) ;(mutex-unlock! mx1) ))))) lbl)) (store-button store-label) (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10")) (command-launch-button (iup:button "Execute!" #:action (lambda (x) (let* ((cmd (iup:attribute command-text-box "VALUE")) (fullcmd (conc (dtests:get-pre-command) cmd (dtests:get-post-command)))) (debug:print-info 02 "Running command: " fullcmd) (system fullcmd))))) (kill-jobs (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -target " keystring " -runname " runname " -set-state-status KILLREQ,n/a -testpatt %/% " " -state RUNNING")))) (run-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -target " keystring " -runname " runname " -runtests " (conc testname "/" (if (equal? item-path "") "%" item-path)) )))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -remove-runs -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -v")))) (clean-run-execute (lambda (x) (let ((cmd (conc "megatest -remove-runs -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) ";megatest -target " keystring " -runname " runname " -runtests " (conc testname "/" (if (equal? item-path "") "%" item-path)) ))) (system (conc (dtests:get-pre-command) cmd (dtests:get-post-command)))))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -remove-runs -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -v")) ))) (cond ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1))) ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) (else ;; (test-set-status! db run-id test-name state status itemdat) (set! self ;
︙			︙
720 721 722 723 724 725 726 ~~727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761~~ 762 763 764 765 766 767 768	(iup:attribute-set! steps-matrix "0:5" "Duration") (iup:attribute-set! steps-matrix "0:6" "Log File") (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") (let ((proc (lambda (testdat) ~~(let ((max-row 0))~~ ~~(if (not (null? teststeps))~~ ~~(let loop ((hed (car teststeps))~~ ~~(tal~~ (~~cdr~~ teststeps)) ~~(rownum 1)~~ ~~(colnum 1))~~ ~~(if (> rownum max-row)(set! max-row rownum))~~ ~~(let ((val (vector-ref hed (- colnum 1)))~~ ~~(mtrx-rc (conc rownum ":" colnum)))~~ ~~(iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) ""))~~ ~~(if (< colnum 6)~~ ~~(loop hed tal rownum (+ colnum 1))~~ ~~(if (not (null? tal))~~ ~~(loop (car tal)(cdr tal)(+ rownum 1) 1))))))~~ ~~(if (> max-row 0)~~ ~~(begin~~ ~~;; we are going to speculatively clear rows until we find a row that is already cleared~~ ~~(let loop ((rownum (+ max-row 1))~~ ~~(colnum 0)~~ ~~(deleted #f))~~ ~~;; (debug:print-info 0 "cleaning " rownum ":" colnum)~~ ~~(let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum))~~ ~~(next-col (if (eq? colnum 6) 1 (+ colnum 1)))~~ ~~(mtrx-rc (conc rownum ":" colnum))~~ ~~(curr-val (iup:attribute steps-matrix mtrx-rc)))~~ ~~;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val)~~ ~~(if (and (string? curr-val)~~ ~~(not (equal? curr-val "")))~~ ~~(begin~~ ~~(iup:attribute-set! steps-matrix mtrx-rc "")~~ ~~(loop next-row next-col #t))~~ ~~(if (eq? colnum 6) ;; not done, didn't get a full blank row~~ ~~(if deleted (loop next-row next-col #f)) ;; exit on this not met~~ ~~(loop next-row next-col deleted)))))~~ ~~(iup:attribute-set! steps-matrix "REDRAW" "ALL")))))))~~ (hash-table-set! widgets "StepsMatrix" proc) (proc testdat)) steps-matrix) ;; populate the Test Data panel (iup:frame #:title "Test Data" (let ((test-data	< < < \| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < <	657 658 659 660 661 662 663 664 665 666 667 668 669 670 671	(iup:attribute-set! steps-matrix "0:5" "Duration") (iup:attribute-set! steps-matrix "0:6" "Log File") (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") (let ((proc (lambda (testdat) (dcommon:populate-steps teststeps steps-matrix)))) (hash-table-set! widgets "StepsMatrix" proc) (proc testdat)) steps-matrix) ;; populate the Test Data panel (iup:frame #:title "Test Data" (let ((test-data
︙			︙

︙			︙
125 126 127 128 129 130 131 ~~132~~ 133 134 135 136 137 138 139 140 141 142 143 ~~144~~ 145 146 147 148 149 150 151	;; TO-DO ;; 1. Make "data" hash-table hierarchial store of all displayed data ;; 2. Update synchash to understand "get-runs", "get-tests" etc. ;; 3. Add extraction of filters to synchash calls ;; ;; Mode is 'full or 'incremental for full refresh or incremental refresh ~~(define (run-update keys data runname keypatts testpatt states statuses mode window-id)~~ (let* (;; count and offset => #f so not used ;; the synchash calls modify the "data" hash (get-runs-sig (conc (client:get-signature) " get-runs")) (get-tests-sig (conc (client:get-signature) " get-tests")) (get-details-sig (conc (client:get-signature) " get-test-details")) ;; test-ids to get and display are indexed on window-id in curr-test-ids hash (test-ids (hash-table-values (dboard:data-get-curr-test-ids data))) (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data runname #f #f keypatts)) (tests-detail-changes (if (not (null? test-ids)) ~~(synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data test-ids)~~ '())) ;; Now can calculate the run-ids (run-hash (hash-table-ref/default data get-runs-sig #f)) (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) (test-changes (synchash:client-get 'db:get-tests-for-runs-mindata get-tests-sig 0 data run-ids testpatt states statuses #f))	\| \|	125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151	;; TO-DO ;; 1. Make "data" hash-table hierarchial store of all displayed data ;; 2. Update synchash to understand "get-runs", "get-tests" etc. ;; 3. Add extraction of filters to synchash calls ;; ;; Mode is 'full or 'incremental for full refresh or incremental refresh (define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id) (let* (;; count and offset => #f so not used ;; the synchash calls modify the "data" hash (get-runs-sig (conc (client:get-signature) " get-runs")) (get-tests-sig (conc (client:get-signature) " get-tests")) (get-details-sig (conc (client:get-signature) " get-test-details")) ;; test-ids to get and display are indexed on window-id in curr-test-ids hash (test-ids (hash-table-values (dboard:data-get-curr-test-ids data))) (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data runname #f #f keypatts)) (tests-detail-changes (if (not (null? test-ids)) (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids) '())) ;; Now can calculate the run-ids (run-hash (hash-table-ref/default data get-runs-sig #f)) (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) (test-changes (synchash:client-get 'db:get-tests-for-runs-mindata get-tests-sig 0 data run-ids testpatt states statuses #f))
︙			︙
226 227 228 229 230 231 232 ~~233~~ 234 235 236 237 238 239 240 241 242 243	(testname (db:mintest-get-testname test)) (itempath (db:mintest-get-item_path test)) (fullname (conc testname "/" itempath)) (dispname (if (string=? itempath "") testname (conc " " itempath))) (rownum (hash-table-ref/default testname-to-row fullname #f)) (test-path (append run-path (if (equal? itempath "") (list testname) ~~(list testname itempath)))))~~ (tree:add-node (dboard:data-get-tests-tree data) "Runs" test-path userdata: (conc "test-id: " test-id)) (hash-table-set! (dboard:data-get-path-test-ids data) test-path test-id) (if (not rownum) (let ((rownums (hash-table-values testname-to-row))) (set! rownum (if (null? rownums) 1 (+ 1 (apply max rownums)))) (hash-table-set! testname-to-row fullname rownum)	\| > > > > > >	226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249	(testname (db:mintest-get-testname test)) (itempath (db:mintest-get-item_path test)) (fullname (conc testname "/" itempath)) (dispname (if (string=? itempath "") testname (conc " " itempath))) (rownum (hash-table-ref/default testname-to-row fullname #f)) (test-path (append run-path (if (equal? itempath "") (list testname) (list testname itempath)))) (tb (dboard:data-get-tests-tree data))) (print "INFONOTE: run-path: " run-path) (tree:add-node (dboard:data-get-tests-tree data) "Runs" test-path userdata: (conc "test-id: " test-id)) (let ((node-num (tree:find-node tb (cons "Runs" test-path))) (color (car (gutils:get-color-for-state-status state status)))) (debug:print 0 "node-num: " node-num ", color: " color) (iup:attribute-set! tb (conc "COLOR" node-num) color)) (hash-table-set! (dboard:data-get-path-test-ids data) test-path test-id) (if (not rownum) (let ((rownums (hash-table-values testname-to-row))) (set! rownum (if (null? rownums) 1 (+ 1 (apply max rownums)))) (hash-table-set! testname-to-row fullname rownum)
︙			︙
438 439 440 441 442 443 444 ~~445~~ 446 447 448 449 450 451 452 453 ~~454~~ 455 456 457 458 459 460 461	(set! dashboard:update-summary-tab updater) (iup:attribute-set! stats-matrix "WIDTHDEF" "40") (iup:vbox ;; (iup:label "Run statistics" #:expand "HORIZONTAL") stats-matrix))) (define (dcommon:servers-table) ~~~~(let* (~~(colnum 0)~~ (rownum 0) (servers-matrix (iup:matrix #:expand "YES" #:numcol 7 #:numcol-visible 7 #:numlin-visible 5 )) (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId")) (updater (lambda () ~~(let ((servers (~~open-run-close~~ tasks:get-all-servers ~~tasks:open-~~db)))~~ (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) ;; (set! colnum 0) ;; (for-each (lambda (colname) ;; ;; (print "colnum: " colnum " colname: " colname) ;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) ;; (set! colnum (+ 1 colnum))) ;; colnames)	> \| \|	444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468	(set! dashboard:update-summary-tab updater) (iup:attribute-set! stats-matrix "WIDTHDEF" "40") (iup:vbox ;; (iup:label "Run statistics" #:expand "HORIZONTAL") stats-matrix))) (define (dcommon:servers-table) (let* ((tdbdat (tasks:open-db)) (colnum 0) (rownum 0) (servers-matrix (iup:matrix #:expand "YES" #:numcol 7 #:numcol-visible 7 #:numlin-visible 5 )) (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId")) (updater (lambda () (let ((servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))) (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) ;; (set! colnum 0) ;; (for-each (lambda (colname) ;; ;; (print "colnum: " colnum " colname: " colname) ;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) ;; (set! colnum (+ 1 colnum))) ;; colnames)
︙			︙
544 545 546 547 548 549 550	;; #:modal? #t ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current ;; ;; #:x 'mouse ;; ;; #:y 'mouse ;; ) ))))	> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > >	551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772	;; #:modal? #t ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current ;; ;; #:x 'mouse ;; ;; #:y 'mouse ;; ) )))) ;;====================================================================== ;; CANVAS STUFF FOR TESTS ;;====================================================================== (define (dcommon:draw-test cnv x y w h name selected) (let* ((llx x) (lly y) (urx (+ x w)) (ury (+ y h))) (canvas-text! cnv (+ llx 5)(+ lly 5) name) ;; (conc testname " (" xtorig "," ytorig ")")) (canvas-rectangle! cnv llx urx lly ury) (if selected (canvas-box! cnv llx (+ llx 5) lly (+ lly 5))))) (define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames) (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8)) (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset)) (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset)) (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1)))) (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5)))) (boxw 90) ;; default, overriden by length estimate below (boxh 25) (gapx 20) (gapy 30) (tests-hash (hash-table-ref tests-draw-state 'tests-info)) (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) (hash-table-set! tests-draw-state 'xtorig xtorig) (hash-table-set! tests-draw-state 'ytorig ytorig) (let ((longest-str (if (null? sorted-testnames) " " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b)))))))) (let-values (((x-max y-max) (canvas-text-size cnv longest-str))) (if (> x-max boxw)(set! boxw (+ 10 x-max))))) ;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj) (if (not (null? sorted-testnames)) (let loop ((hed (car (reverse sorted-testnames))) (tal (cdr (reverse sorted-testnames))) (llx xtorig) (lly ytorig) (urx (+ xtorig boxw)) (ury (+ ytorig boxh))) ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury) (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) ;; data used by mouse click calc. keep the wacky order for now. (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh)) ;; (list llx lly boxw boxh)) ;; NB// Swap ury and lly (if (not (null? tal)) ;; leave a column of space to the right to list items (let ((have-room (if #t ;; put "auto" here where some form of auto rearanging can be done (> (* 3 (+ boxw gapx)) (- urx xtorig)) (< urx (- sizex boxw gapx boxw))))) ;; is there room for another column? (loop (car tal) (cdr tal) (if have-room (+ llx boxw gapx) xtorig) ;; have room, (if have-room lly (+ lly boxh gapy)) (if have-room (+ urx boxw gapx) (+ xtorig boxw)) (if have-room ury (+ ury boxh gapy))))))))) (define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames) (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8)) (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset)) (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset)) (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1)))) (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5)))) (xdelta (- (hash-table-ref tests-draw-state 'xtorig) xtorig)) (ydelta (- (hash-table-ref tests-draw-state 'ytorig) ytorig)) (tests-hash (hash-table-ref tests-draw-state 'tests-info)) (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) (hash-table-set! tests-draw-state 'xtorig xtorig) (hash-table-set! tests-draw-state 'ytorig ytorig) (if (not (null? sorted-testnames)) (let loop ((hed (car (reverse sorted-testnames))) (tal (cdr (reverse sorted-testnames)))) (let* ((tvals (hash-table-ref tests-hash hed)) (llx (+ xdelta (list-ref tvals 0))) (lly (+ ydelta (list-ref tvals 4))) (boxw (list-ref tvals 5)) (boxh (list-ref tvals 6)) (urx (+ llx boxw)) (ury (+ lly boxh))) (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh)) (if (not (null? tal)) ;; leave a column of space to the right to list items (loop (car tal) (cdr tal)))))))) ;;====================================================================== ;; S T E P S ;;====================================================================== ;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!! ;; ;; get a pretty table to summarize steps ;; (define (dcommon:process-steps-table steps);; db test-id #!key (work-area #f)) ;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) ;; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) (debug:print 6 "step=" step) (let ((record (hash-table-ref/default res (tdb:step-get-stepname step) ;; stepname start end status Duration Logfile (vector (tdb:step-get-stepname step) "" "" "" "" "")))) (debug:print 6 "record(before) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)) (case (string->symbol (tdb:step-get-state step)) ((start)(vector-set! record 1 (tdb:step-get-event_time step)) (vector-set! record 3 (if (equal? (vector-ref record 3) "") (tdb:step-get-status step))) (if (> (string-length (tdb:step-get-logfile step)) 0) (vector-set! record 5 (tdb:step-get-logfile step)))) ((end) (vector-set! record 2 (any->number (tdb:step-get-event_time step))) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) (endt (any->number (vector-ref record 2)))) (debug:print 4 "record[1]=" (vector-ref record 1) ", startt=" startt ", endt=" endt ", get-status: " (tdb:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (tdb:step-get-logfile step)) 0) (vector-set! record 5 (tdb:step-get-logfile step)))) (else (vector-set! record 2 (tdb:step-get-state step)) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (tdb:step-get-event_time step)))) (hash-table-set! res (tdb:step-get-stepname step) record) (debug:print 6 "record(after) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)))) ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) (sort steps (lambda (a b) (cond ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) (< (tdb:step-get-id a) (tdb:step-get-id b))) (else #f))))) res)) (define (dcommon:get-compressed-steps dbstruct run-id test-id) (let* ((steps-data (db:get-steps-for-test dbstruct run-id test-id)) (comprsteps (dcommon:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) (map (lambda (x) ;; take advantage of the \n on time->string (vector (vector-ref x 0) (let ((s (vector-ref x 1))) (if (number? s)(seconds->time-string s) s)) (let ((s (vector-ref x 2))) (if (number? s)(seconds->time-string s) s)) (vector-ref x 3) ;; status (vector-ref x 4) (vector-ref x 5))) ;; time delta (sort (hash-table-values comprsteps) (lambda (a b) (let ((time-a (vector-ref a 1)) (time-b (vector-ref b 1))) (if (and (number? time-a)(number? time-b)) (if (< time-a time-b) #t (if (eq? time-a time-b) (string<? (conc (vector-ref a 2)) (conc (vector-ref b 2))) #f)) (string<? (conc time-a)(conc time-b))))))))) (define (dcommon:populate-steps teststeps steps-matrix) (let ((max-row 0)) (if (null? teststeps) (iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS") (let loop ((hed (car teststeps)) (tal (cdr teststeps)) (rownum 1) (colnum 1)) (if (> rownum max-row)(set! max-row rownum)) (let ((val (vector-ref hed (- colnum 1))) (mtrx-rc (conc rownum ":" colnum))) (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) (if (< colnum 6) (loop hed tal rownum (+ colnum 1)) (if (not (null? tal)) (loop (car tal)(cdr tal)(+ rownum 1) 1)))))) (if (> max-row 0) (begin ;; we are going to speculatively clear rows until we find a row that is already cleared (let loop ((rownum (+ max-row 1)) (colnum 0) (deleted #f)) ;; (debug:print-info 0 "cleaning " rownum ":" colnum) (let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum)) (next-col (if (eq? colnum 6) 1 (+ colnum 1))) (mtrx-rc (conc rownum ":" colnum)) (curr-val (iup:attribute steps-matrix mtrx-rc))) ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val) (if (and (string? curr-val) (not (equal? curr-val ""))) (begin (iup:attribute-set! steps-matrix mtrx-rc "") (loop next-row next-col #t)) (if (eq? colnum 6) ;; not done, didn't get a full blank row (if deleted (loop next-row next-col #f)) ;; exit on this not met (loop next-row next-col deleted))))) (iup:attribute-set! steps-matrix "REDRAW" "ALL")))))

︙			︙
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	(debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.") (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals) full-list new-offset limit)) full-list)))) ~~(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal))~~ (let* ((key (list run-id waitons ref-item-path mode)) (res (hash-table-ref/default pre-reqs-met-cache key #f)) (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f))) (if last-time (< (current-seconds)(+ last-time 5)) #f)))) (if useres (let ((result (vector-ref res 1))) (debug:print 4 "Using lazy value res: " result) result) ~~(let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode)))~~ (hash-table-set! pre-reqs-met-cache key (vector (current-seconds) newres)) newres)))) (define (mt:get-run-stats dbstruct run-id) ;; Get run stats from local access, move this ... but where? (db:get-run-stats dbstruct run-id)) (define (mt:discard-blocked-tests run-id failed-test tests test-records) (if (null? tests) tests (begin (debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test) (let loop ((testn (car tests)) (remt (cdr tests)) (res '())) ~~(let ((wa~~itons (vector-ref~~ (hash-table-ref/default test-records testn (vector #f #f '()~~)) 2~~)))~~ ;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons) (if (null? remt) (let ((new-res (reverse res))) ;; (print " new-res: " new-res) new-res) (loop (car remt) (cdr remt) (if (member failed-test waitons) ~~res~~ (cons testn res))))))))) ;;====================================================================== ;; T R I G G E R S ;;====================================================================== (define (mt:process-triggers run-id test-id newstate newstatus)	\| \| > \| > > > \|	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	(debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.") (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals) full-list new-offset limit)) full-list)))) (define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f) ) (let* ((key (list run-id waitons ref-item-path mode)) (res (hash-table-ref/default pre-reqs-met-cache key #f)) (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f))) (if last-time (< (current-seconds)(+ last-time 5)) #f)))) (if useres (let ((result (vector-ref res 1))) (debug:print 4 "Using lazy value res: " result) result) (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmap: itemmap))) ;; (let ((newres (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmap: itemmap))) (hash-table-set! pre-reqs-met-cache key (vector (current-seconds) newres)) newres)))) (define (mt:get-run-stats dbstruct run-id) ;; Get run stats from local access, move this ... but where? (db:get-run-stats dbstruct run-id)) (define (mt:discard-blocked-tests run-id failed-test tests test-records) (if (null? tests) tests (begin (debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test) (let loop ((testn (car tests)) (remt (cdr tests)) (res '())) (let* ((test-dat (hash-table-ref/default test-records testn (vector #f #f '()))) (waitons (vector-ref test-dat 2))) ;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons) (if (null? remt) (let ((new-res (reverse res))) ;; (print " new-res: " new-res) new-res) (loop (car remt) (cdr remt) (if (member failed-test waitons) (begin (debug:print 0 "Discarding test " testn "(" test-dat ") due to " failed-test) res) (cons testn res))))))))) ;;====================================================================== ;; T R I G G E R S ;;====================================================================== (define (mt:process-triggers run-id test-id newstate newstatus)
︙			︙
159 160 161 162 163 164 165 ~~166 167 168 169 170 171 172 173 174 175 176~~ 177 178 179 180 181 182 183 184 185 186 187 ~~188 189~~ ~~190~~ 191 192 193 194 195 196	;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S ;;====================================================================== ;; speed up for common cases with a little logic (define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (cond ((and newstate newstatus newcomment) (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id)) ((and newstate newstatus) (rmt:general-call 'state-status run-id newstate newstatus test-id)) (else (if newstate (rmt:general-call 'set-test-state run-id newstate test-id)) (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id)) (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) (mt:process-triggers run-id test-id newstate newstatus) #t) (define (mt:lazy-read-test-config test-name) (let ((tconf (hash-table-ref/default testconfigs test-name #f))) (if tconf tconf (let ((test-dirs (tests:get-tests-search-path configdat))) (let loop ((hed (car test-dirs)) (tal (cdr test-dirs))) (let ((tconfig-file (conc hed "/" test-name "/testconfig"))) (if (and (file-exists? tconfig-file) (file-read-access? tconfig-file)) ~~(let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...] (hash-table-set! testconfigs test-name newtcfg)~~ ~~newtcfg)~~ (if (null? tal) (begin (debug:print 0 "ERROR: No readable testconfig found for " test-name) #f) (loop (car tal)(cdr tal))))))))))	> > > > > > \| \| \| \| \| \| \| \| \| \| \| > > > > > > > > \| \| > > > \|	163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217	;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S ;;====================================================================== ;; speed up for common cases with a little logic (define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (if (not (and run-id test-id)) (begin (debug:print 0 "ERROR: bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate) (print-call-chain (current-error-port)) #f) (begin (cond ((and newstate newstatus newcomment) (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id)) ((and newstate newstatus) (rmt:general-call 'state-status run-id newstate newstatus test-id)) (else (if newstate (rmt:general-call 'set-test-state run-id newstate test-id)) (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id)) (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) (mt:process-triggers run-id test-id newstate newstatus) #t))) (define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment) (let ((test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path))) (mt:test-set-state-status-by-id test-id new-state new-status new-comment))) (define (mt:lazy-read-test-config test-name) (let ((tconf (hash-table-ref/default testconfigs test-name #f))) (if tconf tconf (let ((test-dirs (tests:get-tests-search-path configdat))) (let loop ((hed (car test-dirs)) (tal (cdr test-dirs))) ;; Setting MT_LINKTREE here is almost certainly unnecessary. (let ((tconfig-file (conc hed "/" test-name "/testconfig"))) (if (and (file-exists? tconfig-file) (file-read-access? tconfig-file)) (let ((link-tree-path (configf:lookup configdat "setup" "linktree")) (old-link-tree (get-environment-variable "MT_LINKTREE"))) (if link-tree-path (setenv "MT_LINKTREE" link-tree-path)) (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...] (hash-table-set! testconfigs test-name newtcfg) (if old-link-tree (setenv "MT_LINKTREE" old-link-tree) (unsetenv "MT_LINKTREE")) newtcfg)) (if (null? tal) (begin (debug:print 0 "ERROR: No readable testconfig found for " test-name) #f) (loop (car tal)(cdr tal))))))))))

︙			︙
49 50 51 52 53 54 55 56 57 58 59 60 61 62	(define (cmd-run-proc-each-line cmd proc . params) ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) (handle-exceptions exn (begin (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) #f) (let-values (((fh fho pid) (if (null? params) (process cmd) (process cmd params)))) (let loop ((curr (read-line fh)) (result '())) (if (not (eof-object? curr))	> >	49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64	(define (cmd-run-proc-each-line cmd proc . params) ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) (handle-exceptions exn (begin (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) #f) (let-values (((fh fho pid) (if (null? params) (process cmd) (process cmd params)))) (let loop ((curr (read-line fh)) (result '())) (if (not (eof-object? curr))
︙			︙
122 123 124 125 126 127 128 ~~129~~	(let loop ((inl (read-line)) (res '())) (if (eof-object? inl) (reverse res) (let ((pid (string->number inl))) (if proc (proc pid)) (loop (read-line) (cons pid res))))))))	\| > > > > > > > > >	124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140	(let loop ((inl (read-line)) (res '())) (if (eof-object? inl) (reverse res) (let ((pid (string->number inl))) (if proc (proc pid)) (loop (read-line) (cons pid res)))))))) (define (process:alive? pid) (handle-exceptions exn ;; possibly pid is a process not a child, look in /proc to see if it is running still (file-exists? (conc "/proc/" pid)) (let-values (((rpid exit-type exit-signal)(process-wait pid #t))) (and (number? rpid) (equal? rpid pid)))))

︙			︙
9 10 11 12 13 14 15 ~~16 17~~ 18 19 20 21 22 23 24	(declare (uses common)) (include "common_records.scm") (define (setup-env-defaults fname run-id already-seen keyvals #!key (environ-patt #f)(change-env #t)) (let* ((keys (map car keyvals)) (thekey (if keyvals (string-intersperse (map (lambda (x)(if x x "-na-")) (map cadr keyvals)) "/") ~~(or (args:get-~~arg "-req~~targ") ~~(args:get-arg "-target")~~~~ (get-environment-variable "MT_TARGET") (begin (debug:print 0 "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg") "nothing matches this I hope")))) ;; Why was system disallowed in the reading of the runconfigs file? ;; NOTE: Should be setting env vars based on (target\|default) (confdat (read-config fname #f #t environ-patt: environ-patt sections: (list "default" thekey)))	\| <	9 10 11 12 13 14 15 16 17 18 19 20 21 22 23	(declare (uses common)) (include "common_records.scm") (define (setup-env-defaults fname run-id already-seen keyvals #!key (environ-patt #f)(change-env #t)) (let* ((keys (map car keyvals)) (thekey (if keyvals (string-intersperse (map (lambda (x)(if x x "-na-")) (map cadr keyvals)) "/") (or (common:args-get-target) (get-environment-variable "MT_TARGET") (begin (debug:print 0 "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg") "nothing matches this I hope")))) ;; Why was system disallowed in the reading of the runconfigs file? ;; NOTE: Should be setting env vars based on (target\|default) (confdat (read-config fname #f #t environ-patt: environ-patt sections: (list "default" thekey)))
︙			︙
58 59 60 61 62 63 64 ~~65 66~~ 67 68 69 70 71 72 73 74 75 76 77	(debug:print 2 "---") (set! already-seen-runconfig-info #t))) finaldat)) (define (set-run-config-vars run-id keyvals targ-from-db) (push-directory toppath) ;; the push/pop doesn't appear to do anything ... (let ((runconfigf (conc toppath "/runconfigs.config")) ~~(targ (or (args~~:get-arg "~~-target") ~~(args:get-arg "-reqtarg")~~~~ targ-from-db (get-environment-variable "MT_TARGET")))) (pop-directory) (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id #t keyvals environ-patt: (conc "(default" (if targ (conc "\|" targ ")") ")"))) (debug:print 0 "WARNING: You do not have a run config file: " runconfigf))))	\| <	57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75	(debug:print 2 "---") (set! already-seen-runconfig-info #t))) finaldat)) (define (set-run-config-vars run-id keyvals targ-from-db) (push-directory toppath) ;; the push/pop doesn't appear to do anything ... (let ((runconfigf (conc toppath "/runconfigs.config")) (targ (or (common:args-get-target) targ-from-db (get-environment-variable "MT_TARGET")))) (pop-directory) (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id #t keyvals environ-patt: (conc "(default" (if targ (conc "\|" targ ")") ")"))) (debug:print 0 "WARNING: You do not have a run config file: " runconfigf))))

︙			︙
19 20 21 22 23 24 25 26 27 28 29 30 31 32	(declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (declare (uses synchash)) (declare (uses http-transport)) (declare (uses rpc-transport)) (declare (uses daemon)) (include "common_records.scm") (include "db_records.scm") (define (server:make-server-url hostport) (if (not hostport)	> >	19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34	(declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (declare (uses synchash)) (declare (uses http-transport)) (declare (uses rpc-transport)) (declare (uses nmsg-transport)) (declare (uses launch)) (declare (uses daemon)) (include "common_records.scm") (include "db_records.scm") (define (server:make-server-url hostport) (if (not hostport)
︙			︙
44 45 46 47 48 49 50 ~~51 52 53 54~~ ~~55 56~~ 57 58 59 60 61 62 63	;; ;; all routes though here end in exit ... ;; ;; start_server ;; (define (server:launch run-id) ~~(le~~t ((~~transport ~~(server:get~~-t~~ransport)))~~ (~~case~~ transport ((~~http~~) ~~(http~~-transport:launch run-id)) ((rpc) (rpc-transport:launch run-id))~~ ~~(else (debug:print 0 "ERROR: No known transport set, transport=" transport ", using rpc") (rpc-transport:launch run-id)))))~~ ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;; Get the transport (define (server:get-transport)	\| \| \| \| > \| \|	46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66	;; ;; all routes though here end in exit ... ;; ;; start_server ;; (define (server:launch run-id) (case transport-type ((http)(http-transport:launch run-id)) ((nmsg)(nmsg-transport:launch run-id)) ((rpc) (rpc-transport:launch run-id)) (else (debug:print 0 "ERROR: unknown server type " transport-type)))) ;; (else (debug:print 0 "ERROR: No known transport set, transport=" transport ", using rpc") ;; (rpc-transport:launch run-id))))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;; Get the transport (define (server:get-transport)
︙			︙
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 ~~149~~ 150 151 152 153 ~~154~~ 155 156 ~~157~~ 158 159 160 161 162 163 164 165	result))) ;; Given a run id start a server process ### NOTE ### > file 2>&1 ;; if the run-id is zero and the target-host is set ;; try running on that host ;; (define (server:run run-id) ~~~~(let* (~~(target-host (configf:lookup configdat "server" "homehost" ))~~ (cmdln (conc (common:get-megatest-exe) ~~" -server - -run-id " run-id ~~" >> "~~ ~~topp~~ath "~~/db/~~" ~~run-id~~ "~~.log 2>&1 &"))~~)~~ (debug:print 0 "INFO: Starting server (" cmdln ") as none running ...") (push-directory toppath) ~~(if target-host~~ (begin ~~(set~~-environment-variable~~ "TARGETHOST" target-host)~~ ~~(system (conc "nbfake " cmdln)))~~ ~~(system cmdln))~~ (pop-directory))) (define (server:get-client-signature) (if my-client-signature my-client-signature (let ((sig (server:mk-signature))) (set! my-client-signature sig) my-client-signature))) ;; kind start up of servers, wait 40 seconds before allowing another server for a given ;; run-id to be launched (define (server:kind-run run-id) (let ((last-run-time (hash-table-ref/default server-kind-run run-id #f))) (if (or (not last-run-time) ~~(> (- (current-seconds) last-run-time) 40))~~ (begin (server:run run-id) (hash-table-set! server-kind-run run-id (current-seconds)))))) ;; The generic run a server command. Dispatches the call to server 0 if run-id != 0 ;; (define (server:try-running run-id) (if (eq? run-id 0) (server:run run-id) (rmt:start-server run-id))) (define (server:check-if-running run-id) ~~(let loop ((server (~~open-run-close~~ tasks:get-server ~~tasks:open-~~db run-id)) (trycount 0))~~ (if server ;; note: client:start will set runremote. this needs to be changed ;; also, client:start will login to the server, also need to change that. ;; ;; client:start returns #t if login was successful. ;; ~~(let~~ ((~~res~~ (server:ping-server run-id ~~(vector-ref server 1)(vector-ref server 0))))~~ ;; if the server didn't respond we must remove the record (if res #t (begin ~~(~~open-run-close~~ tasks:server-force-clean-running-records-for-run-id ~~tasks:open-~~db run-id~~ " server:check-if-running") res))) ~~#f)))~~ (define (server:ping-server run-id iface port) (with-input-from-pipe (conc (common:get-megatest-exe) " -run-id " run-id " -ping " (conc iface ":" port)) (lambda () (let loop ((inl (read-line)) (res "NOREPLY")) (if (eof-object? inl)	> > \| > > \| > > > > > \| > > > > > \| > \| > > \| \| > \| \| > \| > > > > > > \| > > > > > > > > > \| > > > > > > > > > > > > > > > > > > > > > > > > > >	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 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228	result))) ;; Given a run id start a server process ### NOTE ### > file 2>&1 ;; if the run-id is zero and the target-host is set ;; try running on that host ;; (define (server:run run-id) (let* ((curr-host (get-host-name)) (curr-ip (server:get-best-guess-address curr-host)) (target-host (configf:lookup configdat "server" "homehost" )) (testsuite (common:get-testsuite-name)) (logfile (conc toppath "/logs/" run-id ".log")) (cmdln (conc (common:get-megatest-exe) " -server " (or target-host "-") " -run-id " run-id (if (equal? (configf:lookup configdat "server" "daemonize") "yes") (conc " -daemonize -log " logfile) "") " -debug 4 testsuite:" testsuite))) ;; (conc " >> " logfile " 2>&1 &"))))) (debug:print 0 "INFO: Starting server (" cmdln ") as none running ...") (push-directory toppath) (if (not (directory-exists? "logs"))(create-directory "logs")) ;; host.domain.tld match host? (if (and target-host ;; look at target host, is it host.domain.tld or ip address and does it ;; match current ip or hostname (not (string-match (conc "("curr-host "\|" curr-host"\\..)") target-host)) (not (equal? curr-ip target-host))) (begin (debug:print-info 0 "Starting server on " target-host ", logfile is " logfile) (setenv "TARGETHOST" target-host))) (setenv "TARGETHOST_LOGF" logfile) (system (conc "nbfake " cmdln)) (unsetenv "TARGETHOST_LOGF") (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) ;; (system cmdln) (pop-directory))) (define (server:get-client-signature) (if my-client-signature* my-client-signature (let ((sig (server:mk-signature))) (set! my-client-signature sig) my-client-signature))) ;; kind start up of servers, wait 40 seconds before allowing another server for a given ;; run-id to be launched (define (server:kind-run run-id) (let ((last-run-time (hash-table-ref/default server-kind-run run-id #f))) (if (or (not last-run-time) (> (- (current-seconds) last-run-time) 30)) (begin (server:run run-id) (hash-table-set! server-kind-run run-id (current-seconds)))))) ;; The generic run a server command. Dispatches the call to server 0 if run-id != 0 ;; (define (server:try-running run-id) (if (eq? run-id 0) (server:run run-id) (rmt:start-server run-id))) (define (server:check-if-running run-id) (let ((tdbdat (tasks:open-db))) (let loop ((server (tasks:get-server (db:delay-if-busy tdbdat) run-id)) (trycount 0)) (if server ;; note: client:start will set runremote. this needs to be changed ;; also, client:start will login to the server, also need to change that. ;; ;; client:start returns #t if login was successful. ;; (let ((res (case transport-type ((http)(server:ping-server run-id (tasks:hostinfo-get-interface server) (tasks:hostinfo-get-port server))) ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server) (tasks:hostinfo-get-port server) timeout: 2))))) ;; if the server didn't respond we must remove the record (if res #t (begin (debug:print-info 0 "server at " server " not responding, removing record") (tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id " server:check-if-running") res))) #f)))) ;; called in megatest.scm, host-port is string hostname:port ;; (define (server:ping run-id host:port) (let ((tdbdat (tasks:open-db))) (let* ((host-port (let ((slst (string-split host:port ":"))) (if (eq? (length slst) 2) (list (car slst)(string->number (cadr slst))) #f))) (toppath (launch:setup-for-run)) (server-db-dat (if (not host-port)(tasks:get-server (db:delay-if-busy tdbdat) run-id) #f))) (if (not run-id) (begin (debug:print 0 "ERROR: must specify run-id when doing ping, -run-id n") (print "ERROR: No run-id") (exit 1)) (if (and (not host-port) (not server-db-dat)) (begin (print "ERROR: bad host:port") (exit 1)) (let* ((iface (if host-port (car host-port) (tasks:hostinfo-get-interface server-db-dat))) (port (if host-port (cadr host-port)(tasks:hostinfo-get-port server-db-dat))) (server-dat (http-transport:client-connect iface port)) (login-res (rmt:login-no-auto-client-setup server-dat run-id))) (if (and (list? login-res) (car login-res)) (begin (print "LOGIN_OK") (exit 0)) (begin (print "LOGIN_FAILED") (exit 1))))))))) ;; run ping in separate process, safest way in some cases ;; (define (server:ping-server run-id iface port) (with-input-from-pipe (conc (common:get-megatest-exe) " -run-id " run-id " -ping " (conc iface ":" port)) (lambda () (let loop ((inl (read-line)) (res "NOREPLY")) (if (eof-object? inl)
︙			︙
175 176 177 178 179 180 181	(if (equal? toppath toppath) (begin ;; (debug:print-info 2 "login successful") #t) (begin ;; (debug:print-info 2 "login failed") #f))))	> > > > > > > > > > >	238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255	(if (equal? toppath toppath) (begin ;; (debug:print-info 2 "login successful") #t) (begin ;; (debug:print-info 2 "login failed") #f)))) (define (server:get-timeout) (let ((tmo (configf:lookup configdat "server" "timeout"))) (if (and (string? tmo) (string->number tmo)) (* 60 60 (string->number tmo)) ;; (* 3 24 60 60) ;; default to three days (* 60 1) ;; default to one minute ;; (* 60 60 25) ;; default to 25 hours )))

︙			︙
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24	;;====================================================================== ;;====================================================================== ;; A hash of hashes that can be kept in sync by sending minial deltas ;;====================================================================== (use format) ~~(use srfi-1 srfi-69)~~ (declare (unit synchash)) (declare (uses db)) (declare (uses server)) (include "db_records.scm") (define (synchash:make)	\| >	10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25	;;====================================================================== ;;====================================================================== ;; A hash of hashes that can be kept in sync by sending minial deltas ;;====================================================================== (use format) (use srfi-1 srfi-69 sqlite3) (import (prefix sqlite3 sqlite3:)) (declare (unit synchash)) (declare (uses db)) (declare (uses server)) (include "db_records.scm") (define (synchash:make)
︙			︙
60 61 62 63 64 65 66 67 68 69 70 71 72 73 74	;; (cdb:remote-run db:get-keys #f) ;; (cdb:remote-run db:get-num-runs #f "%") ;; (cdb:remote-run db:get-runs #f runnamepatt numruns start-run-offset keypatts) ;; ;; keynum => the field to use as the unique key (usually 0 but can be other field) ;; (define (synchash:client-get proc synckey keynum synchash . params) ~~(let* ((data (apply cdb:remote-run synchash:server-get #f proc synckey keynum params))~~ (newdat (car data)) (removs (cadr data)) (myhash (hash-table-ref/default synchash synckey #f))) (if (not myhash) (begin (set! myhash (make-hash-table)) (hash-table-set! synchash synckey myhash)))	\| >	61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76	;; (cdb:remote-run db:get-keys #f) ;; (cdb:remote-run db:get-num-runs #f "%") ;; (cdb:remote-run db:get-runs #f runnamepatt numruns start-run-offset keypatts) ;; ;; keynum => the field to use as the unique key (usually 0 but can be other field) ;; (define (synchash:client-get proc synckey keynum synchash . params) (let* ((data ;; (apply cdb:remote-run synchash:server-get #f proc synckey keynum params)) (apply synchash:server-get #f proc synckey keynum params)) (newdat (car data)) (removs (cadr data)) (myhash (hash-table-ref/default synchash synckey #f))) (if (not myhash) (begin (set! myhash (make-hash-table)) (hash-table-set! synchash synckey myhash)))
︙			︙
85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101	removs) ;; WHICH ONE!? ;; data)) ;; return the changed and deleted list (list newdat removs))) ;; synchash)) (define synchashes (make-hash-table)) ~~(define (synchash:server-get db proc synckey keynum . params)~~ ;; (debug:print-info 2 "synckey: " synckey ", keynum: " keynum ", params: " params) ~~~~(let* (~~(synchash (hash-table-ref/default synchashes synckey #f))~~ (newdat (apply (case proc ((db:get-runs) db:get-runs) ((db:get-tests-for-runs-mindata) db:get-tests-for-runs-mindata) ((db:get-test-info-by-ids) db:get-test-info-by-ids) (else (print "ERROR: sync for hash " proc " not setup! Edits needed in synchash.scm") print))	\| > \|	87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104	removs) ;; WHICH ONE!? ;; data)) ;; return the changed and deleted list (list newdat removs))) ;; synchash)) (define synchashes (make-hash-table)) (define (synchash:server-get indb proc synckey keynum . params) ;; (debug:print-info 2 "synckey: " synckey ", keynum: " keynum ", params: " params) (let* ((db (if indb indb (db:open-megatest-db))) (synchash (hash-table-ref/default synchashes synckey #f)) (newdat (apply (case proc ((db:get-runs) db:get-runs) ((db:get-tests-for-runs-mindata) db:get-tests-for-runs-mindata) ((db:get-test-info-by-ids) db:get-test-info-by-ids) (else (print "ERROR: sync for hash " proc " not setup! Edits needed in synchash.scm") print))
︙			︙
112 113 114 115 116 117 118 119 120 121 122 123 124	;; (debug:print-info 2 "header: " header ", data: " data) (cons (list "header" header) ;; add the header keyed by the word "header" (map make-indexed data)))) ;; add each element keyed by the keynum'th val (else ;; (debug:print-info 2 "Non-get runs call") (map make-indexed newdat)))) ;; (debug:print-info 2 "postdat: " postdat) (if (not synchash) (begin (set! synchash (make-hash-table)) (hash-table-set! synchashes synckey synchash))) (synchash:get-delta postdat synchash)))	>	115 116 117 118 119 120 121 122 123 124 125 126 127 128	;; (debug:print-info 2 "header: " header ", data: " data) (cons (list "header" header) ;; add the header keyed by the word "header" (map make-indexed data)))) ;; add each element keyed by the keynum'th val (else ;; (debug:print-info 2 "Non-get runs call") (map make-indexed newdat)))) ;; (debug:print-info 2 "postdat: " postdat) ;; (if (not indb)(sqlite3:finalize! db)) (if (not synchash) (begin (set! synchash (make-hash-table)) (hash-table-set! synchashes synckey synchash))) (synchash:get-delta postdat synchash)))

︙			︙
20 21 22 23 24 25 26 27 28 29 30 31 32 33	(declare (unit tdb)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) (declare (uses client)) (declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") ;;======================================================================	>	20 21 22 23 24 25 26 27 28 29 30 31 32 33 34	(declare (unit tdb)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) (declare (uses client)) (declare (uses mt)) (declare (uses db)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") ;;======================================================================
︙			︙
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	(dbexists (file-exists? dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) (handle-exceptions exn (begin (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ((condition-property-accessor 'exn 'message) exn)) ~~(set! db (sqlite3:open-database ":memory:"))) ;; open an in-memory db to allow readonly access~~ (set! db (sqlite3:open-database dbpath))) (if db-write-access (sqlite3:set-busy-handler! db handler)) (if (not dbexists) (begin ~~(sqlite3:execute db "PRAGMA synchronous = FULL;")~~ (debug:print-info 11 "Initialized test database " dbpath) (tdb:testdb-initialize db))) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") (debug:print-info 11 "open-test-db END (sucessful)" work-area) ;; now let's test that everything is correct (handle-exceptions exn (begin ~~(debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"~~ ((condition-property-accessor 'exn 'message) exn)) #f) ;; Is there a cheaper single line operation that will check for existance of a table ;; and raise an exception ? (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;")) db) (let ((baddb (sqlite3:open-database ":memory:")))	> \| > \| > \| >	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	(dbexists (file-exists? dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) (handle-exceptions exn (begin (print-call-chain (current-error-port)) (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ((condition-property-accessor 'exn 'message) exn)) (set! db (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access (set! dbexists #f)) ;; must force re-creation of tables, more tom-foolery (set! db (sqlite3:open-database dbpath))) (if db-write-access (sqlite3:set-busy-handler! db handler)) (if (not dbexists) (begin (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;") (debug:print-info 11 "Initialized test database " dbpath) (tdb:testdb-initialize db))) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") (debug:print-info 11 "open-test-db END (sucessful)" work-area) ;; now let's test that everything is correct (handle-exceptions exn (begin (print-call-chain (current-error-port)) (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file " dbpath ".\n " ((condition-property-accessor 'exn 'message) exn)) #f) ;; Is there a cheaper single line operation that will check for existance of a table ;; and raise an exception ? (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;")) db) (let ((baddb (sqlite3:open-database ":memory:")))
︙			︙
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 149~~ 150 151 152 153 ~~154~~ 155 156 157 158 159 160 161	work-area (db:test-get-rundir-from-test-id dbstruct run-id test-id))) (tdb (open-test-db test-path))) (apply proc tdb params))) (define (tdb:testdb-initialize db) (debug:print 11 "db:testdb-initialize START") ~~(for-each (lambda (sqlcmd) (sqlite3:execute db sqlcmd)) (list "CREATE TABLE IF NOT EXISTS test_rundat (~~ id INTEGER PRIMARY KEY, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, diskusage INTGER DEFAULT -1, run_duration INTEGER DEFAULT 0);" ~~"CREATE TABLE IF NOT EXISTS test_data (~~ id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, tol REAL, units TEXT, comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));" ~~"CREATE TABLE IF NOT EXISTS test_steps (~~ id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));" ~~;; test_meta can be used for handing commands to the test ;; e.g. KILLREQ ;; the ackstate is set to 1 once the command has been completed "CREATE TABLE IF NOT EXISTS test_meta (~~ id INTEGER PRIMARY KEY, var TEXT, val TEXT, ackstate INTEGER DEFAULT 0, ~~CONSTRAINT metadat_constraint UNIQUE (var));"))~~ (debug:print 11 "db:testdb-initialize END")) (define (tdb:read-test-data tdb test-id categorypatt) (let ((res '())) (sqlite3:for-each-row (lambda (id test_id category variable value expected tol units comment status type) (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))	> > > \| \| \| \| \| \| \| \| \| \| \|	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 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169	work-area (db:test-get-rundir-from-test-id dbstruct run-id test-id))) (tdb (open-test-db test-path))) (apply proc tdb params))) (define (tdb:testdb-initialize db) (debug:print 11 "db:testdb-initialize START") (sqlite3:with-transaction db (lambda () (for-each (lambda (sqlcmd) (sqlite3:execute db sqlcmd)) (list "CREATE TABLE IF NOT EXISTS test_rundat ( id INTEGER PRIMARY KEY, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, diskusage INTGER DEFAULT -1, run_duration INTEGER DEFAULT 0);" "CREATE TABLE IF NOT EXISTS test_data ( id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, tol REAL, units TEXT, comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));" "CREATE TABLE IF NOT EXISTS test_steps ( id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));" ;; test_meta can be used for handing commands to the test ;; e.g. KILLREQ ;; the ackstate is set to 1 once the command has been completed "CREATE TABLE IF NOT EXISTS test_meta ( id INTEGER PRIMARY KEY, var TEXT, val TEXT, ackstate INTEGER DEFAULT 0, CONSTRAINT metadat_constraint UNIQUE (var));")))) (debug:print 11 "db:testdb-initialize END")) (define (tdb:read-test-data tdb test-id categorypatt) (let ((res '())) (sqlite3:for-each-row (lambda (id test_id category variable value expected tol units comment status type) (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
︙			︙

︙			︙
29 30 31 32 33 34 35 ~~36 37~~ 38 39 40 41 42 43 44	(include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") ;; Call this one to do all the work and get a standardized list of tests (define (tests:get-all) ~~~~(let* ((test-search-path (cons (conc toppath "/tests") ;; the default~~ (tests:get-tests-search-path configdat))))~~ (tests:get-valid-tests (make-hash-table) test-search-path))) (define (tests:get-tests-search-path cfgdat) (let ((paths (map cadr (configf:get-section cfgdat "tests-paths")))) (cons (conc toppath "/tests") paths))) (define (tests:get-valid-tests test-registry tests-paths)	< \|	29 30 31 32 33 34 35 36 37 38 39 40 41 42 43	(include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") ;; Call this one to do all the work and get a standardized list of tests (define (tests:get-all) (let* ((test-search-path (tests:get-tests-search-path configdat))) (tests:get-valid-tests (make-hash-table) test-search-path))) (define (tests:get-tests-search-path cfgdat) (let ((paths (map cadr (configf:get-section cfgdat "tests-paths")))) (cons (conc toppath "/tests") paths))) (define (tests:get-valid-tests test-registry tests-paths)
︙			︙
66 67 68 69 70 71 72 ~~73 74~~ 75 76 77 78 79 80 81	;; tests:glob-like-match (define (tests:glob-like-match patt str) (let ((like (substring-index "%" patt))) (let* ((notpatt (equal? (substring-index "~" patt) 0)) (newpatt (if notpatt (substring patt 1) patt)) (finpatt (if like ~~(string-substitute (regexp "%") "." newpatt) (string-substitute (regexp "\\") ".*" newpatt)))~~ (res #f)) ;; (print "tests:glob-like-match => notpatt: " notpatt ", newpatt: " newpatt ", finpatt: " finpatt) (set! res (string-match (regexp finpatt (if like #t #f)) str)) (if notpatt (not res) res)))) ;; if itempath is #f then look only at the testname part ;;	\| \|	65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80	;; tests:glob-like-match (define (tests:glob-like-match patt str) (let ((like (substring-index "%" patt))) (let* ((notpatt (equal? (substring-index "~" patt) 0)) (newpatt (if notpatt (substring patt 1) patt)) (finpatt (if like (string-substitute (regexp "%") "." newpatt #f) (string-substitute (regexp "\\") ".*" newpatt #f))) (res #f)) ;; (print "tests:glob-like-match => notpatt: " notpatt ", newpatt: " newpatt ", finpatt: " finpatt) (set! res (string-match (regexp finpatt (if like #t #f)) str)) (if notpatt (not res) res)))) ;; if itempath is #f then look only at the testname part ;;
︙			︙
349 350 351 352 353 354 355 ~~356~~ 357 358 359 360 361 362 363	"<td>" state "</td>" "<td><font color=" (common:get-color-from-status status) ">" status "</font></td>" "<td>" (if (equal? comment "") " " comment) "</td>" "</tr>")))) ~~testdat)~~ (print "<table><tr><td valign=\"top\">") ;; Print out stats for status (set! tot 0) (print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\"2\"><h2>State stats</h2></td></tr>") (for-each (lambda (state) (set! tot (+ tot (hash-table-ref statecounts state))) (print "<tr><td>" state "</td><td>" (hash-table-ref statecounts state) "</td></tr>"))	> \| > > > >	348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367	"<td>" state "</td>" "<td><font color=" (common:get-color-from-status status) ">" status "</font></td>" "<td>" (if (equal? comment "") " " comment) "</td>" "</tr>")))) (if (list? testdat) testdat (begin (print "ERROR: failed to get records with rmt:test-get-records-for-index-file run-id=" run-id "test-name=" test-name) '()))) (print "<table><tr><td valign=\"top\">") ;; Print out stats for status (set! tot 0) (print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\"2\"><h2>State stats</h2></td></tr>") (for-each (lambda (state) (set! tot (+ tot (hash-table-ref statecounts state))) (print "<tr><td>" state "</td><td>" (hash-table-ref statecounts state) "</td></tr>"))
︙			︙
472 473 474 475 476 477 478 ~~479~~ 480 481 482 483 484 485 486	(tests:testqueue-set-priority! b-record b-priority) (if (and a-waitons (member (tests:testqueue-get-testname b-record) a-waitons)) #f ;; cannot have a which is waiting on b happening before b (if (and b-waitons (member (tests:testqueue-get-testname a-record) b-waitons)) #t ;; this is the correct order, b is waiting on a and b is before a (if (> a-priority b-priority) #t ;; if a is a higher priority than b then we are good to go ~~#f))))))))~~ ;; for each test: ;; (define (tests:filter-non-runnable run-id testkeynames testrecordshash) (let ((runnables '())) (for-each (lambda (testkeyname)	\|	476 477 478 479 480 481 482 483 484 485 486 487 488 489 490	(tests:testqueue-set-priority! b-record b-priority) (if (and a-waitons (member (tests:testqueue-get-testname b-record) a-waitons)) #f ;; cannot have a which is waiting on b happening before b (if (and b-waitons (member (tests:testqueue-get-testname a-record) b-waitons)) #t ;; this is the correct order, b is waiting on a and b is before a (if (> a-priority b-priority) #t ;; if a is a higher priority than b then we are good to go (string-compare3 a b))))))))) ;; for each test: ;; (define (tests:filter-non-runnable run-id testkeynames testrecordshash) (let ((runnables '())) (for-each (lambda (testkeyname)
︙			︙
634 635 636 637 638 639 640 ~~641 642 643~~ 644 645 646 ~~647~~ 648 ~~649 650~~ 651 ~~652~~ ~~653~~ 654 655 656 657 658 659 660 661 662 663 664	(rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id) (if minutes (rmt:general-call 'update-run-duration run-id minutes test-id)) (if (and uname hostname) (rmt:general-call 'update-uname-host run-id uname hostname test-id))) ;; This one is for running with no db access (i.e. via rmt: internally) ~~(define (tests:set-full-meta-info test-id run-id minutes work-area) (let* ((~~num-~~re~~cord~~s 0) (cpuload (get-cpu-load))~~ (diskfree (get-df (current-directory))) (uname (get-uname "-srvpio")) (hostname (get-host-name))) ~~(tdb:remote-update-testdat-meta-info run-id test-id work-area cpuload diskfree minutes)~~ (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname))) ~~(define (tests:set-partial-meta-info test-id run-id minutes work-area)~~ (let* ((cpuload (get-cpu-load)) ~~(diskfree (get-df (current-directory))))~~ ~~(t~~db:remote-~~update-testdat-meta-info ~~run-id~~ test-id work-area cpuload diskfree minutes)))~~ ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== (define (test:archive db test-id) #f) (define (test:archive-tests db keynames target) #f)	> \| \| \| < \| \| > \| > > > > > > > > > > > > > > > > > \| >	638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687	(rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id) (if minutes (rmt:general-call 'update-run-duration run-id minutes test-id)) (if (and uname hostname) (rmt:general-call 'update-uname-host run-id uname hostname test-id))) ;; This one is for running with no db access (i.e. via rmt: internally) (define (tests:set-full-meta-info db test-id run-id minutes work-area remtries) ;; (define (tests:set-full-meta-info test-id run-id minutes work-area) ;; (let ((remtries 10)) (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) (uname (get-uname "-srvpio")) (hostname (get-host-name))) (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname))) ;; (define (tests:set-partial-meta-info test-id run-id minutes work-area) (define (tests:set-partial-meta-info test-id run-id minutes work-area remtries) (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) (remtries 10)) (handle-exceptions exn (if (> remtries 0) (begin (print-call-chain (current-error-port)) (debug:print-info 0 "WARNING: failed to set meta info. Will try " remtries " more times") (set! remtries (- remtries 1)) (thread-sleep! 10) (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1))) (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) (debug:print 0 "ERROR: tried for over a minute to update meta info and failed. Giving up") (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port)))) (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) ))) ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== (define (test:archive db test-id) #f) (define (test:archive-tests db keynames target) #f)

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	[fields] sysname TEXT fsname TEXT datapath TEXT # refareas can be searched to find previous runs # the path points to where megatest.db exists [refareas] area1 /tmp/oldarea/megatest [include config/mt_include_1.config] [misc] home #{shell readlink -f $MT_RUN_AREA_HOME} parent #{shell readlink -f $MT_RUN_AREA_HOME/..} [tests-paths] 1 #{get misc parent}/simplerun/tests [setup] # Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding # this may save a few milliseconds on launching tests # launchwait no waivercommentpatt ^WW\d+ [a-z].* ~~# Use http instead of direct filesystem access~~ ~~# transport http~~ ~~# transport fs~~ # If set to "default" the old code is used. Otherwise defaults to 200 or uses # numeric value given. # runqueue 20 # Default runtimelim 1d 1h 1m 10s	> > > > > > > > \| \| <	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 37 38 39 40 41 42	[fields] sysname TEXT fsname TEXT datapath TEXT # refareas can be searched to find previous runs # the path points to where megatest.db exists [refareas] area1 /tmp/oldarea/megatest [include config/mt_include_1.config] [dashboard] pre-command xterm -geometry 180x20 -e " post-command \|& tee results.log ;echo Press any key to continue;bash -c 'read -n 1 -s'" & testsort -event_time [misc] home #{shell readlink -f $MT_RUN_AREA_HOME} parent #{shell readlink -f $MT_RUN_AREA_HOME/..} [tests-paths] 1 #{get misc parent}/simplerun/tests [setup] # Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding # this may save a few milliseconds on launching tests # launchwait no waivercommentpatt ^WW\d+ [a-z].* incomplete-timeout 1 # yes, anything else is no run-wait yes # If set to "default" the old code is used. Otherwise defaults to 200 or uses # numeric value given. # runqueue 20 # Default runtimelim 1d 1h 1m 10s
︙			︙
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	testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log # or for hard links # testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. # FULL or 2, NORMAL or 1, OFF or 0 ~~synchronous ~~OFF~~~~ # Throttle roughly scales the db access milliseconds to seconds delay throttle 0.2 # Max retries allows megatest to re-check that a tests status has changed # as tests can have transient FAIL status occasionally maxretries 20 # Setup continued. [setup] # override the logview command # logviewer (%MTCMD%) 2> /dev/null > /dev/null # override the html viewer launch command # # htmlviewercmd firefox -new-window htmlviewercmd konqueror [validvalues] state start end 0 1 - 2 status pass fail n/a 0 1 running - 2 # These are set before all tests, override them # in the testconfig [pre-launch-env-overrides] section [env-override] # This variable is honored by the loadrunner script. The value is in percent ~~# a value of 200 will stop new jobs from starting.~~ MAX_ALLOWED_LOAD 200 # MT_XTERM_CMD overrides the terminal command # MT_XTERM_CMD xterm -bg lightgreen -fg black SPECIAL_ENV_VARS overide them here - should be seen at launch and in the runs TESTVAR [system echo $PWD]	\| > > > > > > <	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	testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log # or for hard links # testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. # FULL or 2, NORMAL or 1, OFF or 0 synchronous 0 # Throttle roughly scales the db access milliseconds to seconds delay throttle 0.2 # Max retries allows megatest to re-check that a tests status has changed # as tests can have transient FAIL status occasionally maxretries 20 # Setup continued. [setup] # override the logview command # logviewer (%MTCMD%) 2> /dev/null > /dev/null # override the html viewer launch command # # htmlviewercmd firefox -new-window htmlviewercmd konqueror # -runtests automatically deletes the records for tests with the listed states on starting up a run allowing them to re-run # (nb// this is in addition to NOT_STARTED which is automatically re-run) # allow-auto-rerun INCOMPLETE ZERO_ITEMS # could add: STUCK STUCK/DEAD UNKNOWN KILLED KILLREQ PREQ_DISCARD [validvalues] state start end 0 1 - 2 status pass fail n/a 0 1 running - 2 # These are set before all tests, override them # in the testconfig [pre-launch-env-overrides] section [env-override] # This variable is honored by the loadrunner script. The value is in percent MAX_ALLOWED_LOAD 200 # MT_XTERM_CMD overrides the terminal command # MT_XTERM_CMD xterm -bg lightgreen -fg black SPECIAL_ENV_VARS overide them here - should be seen at launch and in the runs TESTVAR [system echo $PWD]
︙			︙
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	# The empty var should have a definition with null string EMPTY_VAR WRAPPEDVAR This var should have the work blah thrice: \ blah \ blah # XTERM [system xterm] # RUNDEAD [system exit 56] [server] # If the server can't be started on this port it will try the next port until # it succeeds port 9080 # This server will keep running this number of hours after last access. # Three minutes is 0.05 hours # timeout 0.025 ~~timeout 0.25~~ ## disks are: ## name host:/path/to/area ## -or- ## name /path/to/area [disks] disk0 /foobarbazz [include config/mt_include_2.config] [include #{getenv USER}_testing.config] [jobgroups] # NOTE: job groups will falsely count the toplevel test as a job. If possible add N	> > > > > > > > \| > > > > > > > > > > >	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 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166	# The empty var should have a definition with null string EMPTY_VAR WRAPPEDVAR This var should have the work blah thrice: \ blah \ blah MAX_ALLOWED_LOAD 200 # XTERM [system xterm] # RUNDEAD [system exit 56] [server] # Use http instead of direct filesystem access transport http # transport fs # transport nmsg synchronous 0 # If the server can't be started on this port it will try the next port until # it succeeds port 9080 # This server will keep running this number of hours after last access. # Three minutes is 0.05 hours # timeout 0.025 timeout 0.061 # Server is required - slower but more resistant to Sqlite issues. required yes # Start server when average query takes longer than this # server-query-threshold 55500 server-query-threshold -1 # daemonize yes # hostname #{scheme (get-host-name)} ## disks are: ## name host:/path/to/area ## -or- ## name /path/to/area [disks] disk0 /foobarbazz disk1 not-a-disk [include config/mt_include_2.config] [include #{getenv USER}_testing.config] [jobgroups] # NOTE: job groups will falsely count the toplevel test as a job. If possible add N
︙			︙

︙			︙
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	(if (> depth node-depth) ;; (+ 1 node-depth)) #f (loop hed tal depth (+ nodenum 1))))) #f)))) ;; top is the top node name zeroeth node VALUE=0 (define (tree:add-node obj top nodelst #!key (userdata #f)) ~~(i~~f (~~not (iup:attribute obj "TITLE0"))~~ (iup:attribute-set! obj "ADDBRANCH0" top)) (cond ~~((not (~~string=~~? top (iup:attribute obj "TITLE0")))~~ (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) ((null? nodelst)) (else (let loop ((hed (car nodelst)) (tal (cdr nodelst)) (depth 1) (pathl (list top))) ;; Because the tree dialog changes node numbers when ;; nodes are added or removed we must look up nodes ;; each and every time. 0 is the top node so default ;; to that. (let* ((newpath (append pathl (list hed))) (parentnode (tree:find-node obj pathl)) (nodenum (tree:find-node obj newpath))) ;; Add the branch under lastnode if not found (if (not nodenum) (begin (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) (if userdata (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata)) (if (null? tal) #t ;; reset to top (loop (car nodelst)(cdr nodelst) 1 (list top)))) (if (null? tal) ;; if null here then this path has already been added	> \| \| >	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	(if (> depth node-depth) ;; (+ 1 node-depth)) #f (loop hed tal depth (+ nodenum 1))))) #f)))) ;; top is the top node name zeroeth node VALUE=0 (define (tree:add-node obj top nodelst #!key (userdata #f)) (if (or (not (string? (iup:attribute obj "TITLE0"))) (string-null? (iup:attribute obj "TITLE0"))) (iup:attribute-set! obj "ADDBRANCH0" top)) (cond ((not (equal? top (iup:attribute obj "TITLE0"))) (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) ((null? nodelst)) (else (let loop ((hed (car nodelst)) (tal (cdr nodelst)) (depth 1) (pathl (list top))) ;; Because the tree dialog changes node numbers when ;; nodes are added or removed we must look up nodes ;; each and every time. 0 is the top node so default ;; to that. (let* ((newpath (append pathl (list hed))) (parentnode (tree:find-node obj pathl)) (nodenum (tree:find-node obj newpath))) ;; Add the branch under lastnode if not found (if (not nodenum) (begin (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) ;; ERROR? ADDING DATA TO PARENT, DONT WE WANT IT ON CREATED NODE? (if userdata (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata)) (if (null? tal) #t ;; reset to top (loop (car nodelst)(cdr nodelst) 1 (list top)))) (if (null? tal) ;; if null here then this path has already been added
︙			︙
109 110 111 112 113 114 115 ~~116~~	(take path node-depth) path)) (newpath (append trimpath (list node-title)))) (if (>= currnode nodenum) newpath (loop (+ currnode 1) newpath)))))	\| > > > > > > > > > > > > > > > > > > > > > > > >	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	(take path node-depth) path)) (newpath (append trimpath (list node-title)))) (if (>= currnode nodenum) newpath (loop (+ currnode 1) newpath))))) (define (tree:delete-node obj top node-path) ;; node-path is a list of strings (let ((id (tree:find-node obj (cons top node-path)))) (print "Found node to remove " id " for path " top " " node-path) (iup:attribute-set! obj (conc "DELNODE" id) "SELECTED"))) #\| (let* ((tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" #:addexpanded "NO" #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) (run-id (tree-path->run-id (cdr run-path)))) (if run-id (begin (dboard:data-set-curr-run-id! data run-id) (dashboard:update-run-summary-tab))) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) )))) \|#

1 2 3 4 5 6 7 8 9 10 11 12 13	<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en"> <head> <meta http-equiv="Content-Type" content="application/xhtml+xml; charset=UTF-8" /> ~~<meta name="generator" content="AsciiDoc 8.6.7" />~~ <title>The Megatest Users Manual</title> <style type="text/css"> /* Shared CSS for AsciiDoc xhtml11 and html5 backends / / Default font. */ body { font-family: Georgia,serif;	\|	1 2 3 4 5 6 7 8 9 10 11 12 13	<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en"> <head> <meta http-equiv="Content-Type" content="application/xhtml+xml; charset=UTF-8" /> <meta name="generator" content="AsciiDoc 8.6.9" /> <title>The Megatest Users Manual</title> <style type="text/css"> /* Shared CSS for AsciiDoc xhtml11 and html5 backends / / Default font. */ body { font-family: Georgia,serif;
︙			︙
83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100	ul, ol, li > p { margin-top: 0; } ul > li { color: #aaa; } ul > li > * { color: black; } ~~pre {~~ padding: 0; margin: 0; } #author { color: #527bbd; font-weight: bold; font-size: 1.1em; } #email {	\| > > > > > >	83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106	ul, ol, li > p { margin-top: 0; } ul > li { color: #aaa; } ul > li > * { color: black; } .monospaced, code, pre { font-family: "Courier New", Courier, monospace; font-size: inherit; color: navy; padding: 0; margin: 0; } pre { white-space: pre-wrap; } #author { color: #527bbd; font-weight: bold; font-size: 1.1em; } #email {
︙			︙
215 216 217 218 219 220 221 ~~222~~ 223 224 225 226 227 228 229	div.exampleblock > div.content { border-left: 3px solid #dddddd; padding-left: 0.5em; } div.imageblock div.content { padding-left: 0; } ~~span.image img { border-style: none; }~~ a.image:visited { color: white; } dl { margin-top: 0.8em; margin-bottom: 0.8em; } dt {	\|	221 222 223 224 225 226 227 228 229 230 231 232 233 234 235	div.exampleblock > div.content { border-left: 3px solid #dddddd; padding-left: 0.5em; } div.imageblock div.content { padding-left: 0; } span.image img { border-style: none; vertical-align: text-bottom; } a.image:visited { color: white; } dl { margin-top: 0.8em; margin-bottom: 0.8em; } dt {
︙			︙
411 412 413 414 415 416 417 ~~418 419 420 421 422 423~~ 424 425 426 427 428 429 430	/* * xhtml11 specific * * */ ~~~~tt {~~ ~~font-family: "Courier New", Courier, monospace;~~ ~~font-size: inherit;~~ ~~color: navy;~~ }~~ div.tableblock { margin-top: 1.0em; margin-bottom: 1.5em; } div.tableblock > table { border: 3px solid #527bbd; }	< < < < < <	417 418 419 420 421 422 423 424 425 426 427 428 429 430	/* * xhtml11 specific * * */ div.tableblock { margin-top: 1.0em; margin-bottom: 1.5em; } div.tableblock > table { border: 3px solid #527bbd; }
︙			︙
450 451 452 453 454 455 456 ~~457 458 459 460 461 462~~ 463 464 465 466 467 468 469	/* * html5 specific * * */ ~~~~.monospaced {~~ ~~font-family: "Courier New", Courier, monospace;~~ ~~font-size: inherit;~~ ~~color: navy;~~ }~~ table.tableblock { margin-top: 1.0em; margin-bottom: 1.5em; } thead, p.tableblock.header { font-weight: bold; color: #527bbd;	< < < < < <	450 451 452 453 454 455 456 457 458 459 460 461 462 463	/* * html5 specific * * */ table.tableblock { margin-top: 1.0em; margin-bottom: 1.5em; } thead, p.tableblock.header { font-weight: bold; color: #527bbd;
︙			︙
535 536 537 538 539 540 541 542 543 544 545 546 547 548	body.manpage div.sectionbody { margin-left: 3em; } @media print { body.manpage div#toc { display: none; } } </style> <script type="text/javascript"> /<![CDATA[/ var asciidoc = { // Namespace. ///////////////////////////////////////////////////////////////////// // Table Of Contents generator	> >	529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544	body.manpage div.sectionbody { margin-left: 3em; } @media print { body.manpage div#toc { display: none; } } </style> <script type="text/javascript"> /<![CDATA[/ var asciidoc = { // Namespace. ///////////////////////////////////////////////////////////////////// // Table Of Contents generator
︙			︙
735 736 737 738 739 740 741 ~~742~~ 743 744 745 746 747 748 749	/]]>/ </script> </head> <body class="book"> <div id="header"> <h1>The Megatest Users Manual</h1> <span id="author">Matt Welland</span><br /> ~~<span id="email"><tt><<a href="mailto:matt@kiatoa.com">matt@kiatoa.com</a>></tt></span><br />~~ <span id="revnumber">version 1.0,</span> <span id="revdate">April 2012</span> </div> <div id="content"> <div class="sect1"> <h2 id="_preface">Preface</h2> <div class="sectionbody">	\|	731 732 733 734 735 736 737 738 739 740 741 742 743 744 745	/]]>/ </script> </head> <body class="book"> <div id="header"> <h1>The Megatest Users Manual</h1> <span id="author">Matt Welland</span><br /> <span id="email"><code><<a href="mailto:matt@kiatoa.com">matt@kiatoa.com</a>></code></span><br /> <span id="revnumber">version 1.0,</span> <span id="revdate">April 2012</span> </div> <div id="content"> <div class="sect1"> <h2 id="_preface">Preface</h2> <div class="sectionbody">
︙			︙
957 958 959 960 961 962 963 ~~964~~ 965 ~~966 967 968 969 970 971 972~~ 973 974 ~~975 976~~ 977 ~~978 979 980 981 982 983~~ 984 985 ~~986~~ 987 ~~988 989 990 991 992 993 994 995 996~~ 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 ~~1009~~ 1010 1011 ~~1012 1013~~ 1014 1015 1016 ~~1017~~ 1018 1019 1020 1021 1022 ~~1023~~ 1024 ~~1025 1026~~ ~~1027 1028~~ ~~1029 1030 1031~~ ~~1032~~ ~~1033 1034 1035~~ 1036 1037 ~~1038~~ 1039 1040 1041 1042 1043 ~~1044~~ 1045 1046 1047 ~~1048~~ 1049 1050 1051 ~~1052~~ 1053 ~~1054~~ 1055 1056 1057 1058 1059 ~~1060~~ 1061 1062 1063 1064 ~~1065~~ 1066 1067 1068 1069 1070 1071 ~~1072~~ 1073 1074 1075 ~~1076~~ 1077 1078 ~~1079~~ 1080 1081 1082 ~~1083~~ 1084 1085 1086 ~~1087~~ 1088 1089 1090 ~~1091~~ 1092 1093 ~~1094~~ 1095 1096 1097 ~~1098~~ 1099 1100 1101 1102 1103 1104 ~~1105~~ 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 ~~1119~~ 1120 1121 1122 1123 ~~1124~~ 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 ~~1182~~ 1183 1184 1185 1186 1187 1188 1189 1190 1191 ~~1192~~ 1193 1194 1195 1196	<h2 id="_tricks">Tricks</h2> <div class="sectionbody"> <div class="paragraph"><p>This section is a compendium of a various useful tricks for debugging, configuring and generally getting the most out of Megatest.</p></div> </div> </div> <div class="sect1"> ~~<h2 id="_~~debugg~~ing_~~trick~~s">~~Debugg~~ing ~~Trick~~s</h2>~~ <div class="sectionbody"> <div class="s~~ect2"~~> ~~<h3 id="_examining_the_environment">Examining The Environment</h3>~~ <div class="s~~ect3"~~> ~~<h4 id="_during_config_file_processing">During Config File Processing</h4>~~ ~~</div>~~ ~~<div class="sect3">~~ ~~<h4 id="_organising_your_tests_and_tasks">Organising Your Tests and Tasks</h4>~~ <div class="listingblock"> <div class="content"> ~~<pre><tt>[test~~s-paths~~] 1 ~~#{get misc parent}/simplerun/tests~~</tt></pre>~~ </div></div> ~~<div class="listingblock">~~ <div class="con~~tent"~~> ~~<pre><tt>[setup]</tt></pre>~~ ~~</div></div>~~ ~~<div class="paragraph"><p>The runscript method is a brute force way to run scripts where the~~ ~~user is responsible for setting STATE and STATUS</p></div>~~ <div class="listingblock"> <div class="content"> ~~~~<pr~~e~~><tt>runscript main.csh~~</tt></pre>~~ </div></div> ~~</div>~~ ~~</div>~~ ~~</div>~~ ~~</div>~~ ~~<div class="sect1">~~ ~~<h2 id="_tricks">Tricks</h2>~~ ~~<div class="sectionbody">~~ ~~<div class="paragraph"><p>This section is a compendium of a various useful tricks for debugging,~~ ~~configuring and generally getting the most out of Megatest.</p></div>~~ </div> </div> <div class="sect1"> <h2 id="_debugging_tricks">Debugging Tricks</h2> <div class="sectionbody"> <div class="sect2"> <h3 id="_examining_the_environment">Examining The Environment</h3> <div class="sect3"> <h4 id="_during_config_file_processing">During Config File Processing</h4> </div> <div class="sect3"> <h4 id="_organising_your_tests_and_tasks">Organising Your Tests and Tasks</h4> ~~<div class="paragraph"><p>/nfs/ch/disks/ch_unienv_disk005/qa_mrwellan/interim/src/megatest/tests/fdktestqa/testqa</p></div>~~ <div class="listingblock"> <div class="content"> ~~<pre><tt>[tests-paths] 1 #{get misc parent}/simplerun/tests</tt></pre>~~ </div></div> <div class="listingblock"> <div class="content"> ~~<pre><tt>[setup]</tt></pre>~~ </div></div> <div class="paragraph"><p>The runscript method is a brute force way to run scripts where the user is responsible for setting STATE and STATUS</p></div> <div class="listingblock"> <div class="content"> ~~<pre><tt>runscript main.csh</tt></pre>~~ </div></div> ~~<div class="~~paragraph~~">~~<p>ww30.2~~ ~~cellname/LVS/cellname.LAYOUT_ERRORS</p></div>~~~~ ~~<div class="~~para~~g~~raph~~"~~><p>Error: text open</p></div~~> <div class="~~paragraph~~">~~<p>ww31.3~~~~ ~~~~cellname/LVS/cellname.LAYOUT_ERRORS</p~~></div> <~~div class="paragraph"><p>Error: text open~~ ~~Reference</p>~~</div>~~ ~~<div class="~~exampleblock~~">~~ ~~<div class="con~~tent~~"> <div class="~~paragraph~~">~~<p>Chapters grouped into book parts are at level 1 and can contain~~ ~~sub-~~sections.</~~p></div~~>~~ <div class="listingblock"> <div class="content"> ~~<pre><tt>[setup]</tt></pre>~~ </div></div> <div class="paragraph"><p>The runscript method is a brute force way to run scripts where the user is responsible for setting STATE and STATUS</p></div> <div class="listingblock"> <div class="content"> ~~<pre><tt>runscript main.csh</tt></pre>~~ </div></div> <div class="listingblock"> <div class="content"> ~~<pre><tt>[requirements]</tt></pre>~~ </div></div> <div class="listingblock"> <div class="content"> ~~<pre><tt># A normal waiton waits for the prior tests to be COMPLETED~~ # and PASS, CHECK or WAIVED ~~waiton test1 test2</tt></pre>~~ </div></div> <div class="paragraph"><p>The default (i.e. if mode is not specified) is normal. All pre-dependent tests must be COMPLETED and PASS, CHECK or WAIVED before the test will start</p></div> <div class="listingblock"> <div class="content"> ~~<pre><tt>mode normal</tt></pre>~~ </div></div> <div class="paragraph"><p>The toplevel mode requires only that the prior tests are COMPLETED.</p></div> <div class="listingblock"> <div class="content"> ~~<pre><tt>mode toplevel</tt></pre>~~ </div></div> <div class="paragraph"><p>A item based waiton will start items in a test when the same-named item is COMPLETED and PASS, CHECK or WAIVED in the prior test</p></div> <div class="listingblock"> <div class="content"> ~~<pre><tt>mode itemmatch</tt></pre>~~ </div></div> <div class="listingblock"> <div class="content"> ~~<pre><tt># With a toplevel test you may wish to generate your list~~ # of tests to run dynamically # ~~# waiton #{shell get-valid-tests-to-run.sh}</tt></pre>~~ </div></div> <div class="listingblock"> <div class="content"> ~~<pre><tt>runtimelim 1h 2m 3s # this will automatically kill the test if it runs for more than 1h 2m and 3s</tt></pre>~~ </div></div> <div class="listingblock"> <div class="content"> ~~<pre><tt>[skip]</tt></pre>~~ </div></div> <div class="listingblock"> <div class="content"> ~~<pre><tt># NB// If the prevrunning line exists with any value the test will~~ # automatically SKIP if the same-named test is currently RUNNING ~~prevrunning x</tt></pre>~~ </div></div> <div class="listingblock"> <div class="content"> ~~<pre><tt>fileexists /path/to/a/file # skip if /path/to/a/file exists</tt></pre>~~ </div></div> <div class="paragraph"><p>If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig: If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED</p></div> <div class="paragraph"><p>Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined)</p></div> <div class="listingblock"> <div class="content"> ~~<pre><tt>###### EXAMPLE FROM testconfig #########~~ # matching file(s) will be diff'd with previous run and logpro applied # if PASS or WARN result from logpro then WAIVER state is set # [waivers] # logpro_file rulename input_glob waiver_1 logpro lookittmp.log [waiver_rules] # This builtin rule is the default if there is no <waivername>.logpro file # diff diff %file1% %file2% # This builtin rule is applied if a <waivername>.logpro file exists ~~# logpro diff %file1% %file2% \| logpro %waivername%.logpro %waivername%.html</tt></pre>~~ </div></div> <div class="paragraph"><p>To transfer the environment to the next step you can do the following:</p></div> <div class="listingblock"> <div class="content"> ~~<pre><tt>$MT_MEGATEST -env2file .ezsteps/${stepname}</tt></pre>~~ </div></div> <div class="sect2"> <h3 id="_megatest_internals">Megatest Internals</h3> <div class="imageblock graphviz"> <div class="content"> <img src="server.png" alt="server.png" /> </div> </div> </div> <div class="paragraph"><p>One or more optional appendixes go here at section level zero.</p></div> <div class="admonitionblock"> <table><tr> <td class="icon"> <div class="title">Note</div> </td> <td class="content">Preface and appendix subsections start out of sequence at level 2 (level 1 is skipped). This only applies to multi-part book documents.</td> </tr></table> </div> <div class="paragraph"><p>The bibliography list is a style of AsciiDoc bulleted list.</p></div> <div class="ulist bibliography"><ul> <li> <p> <a id="taoup"></a>[taoup] Eric Steven Raymond. <em>The Art of Unix Programming</em>. Addison-Wesley. ISBN 0-13-142901-9. </p> </li> <li> <p> <a id="walsh-muellner"></a>[walsh-muellner] Norman Walsh & Leonard Muellner. <em>DocBook - The Definitive Guide</em>. O’Reilly & Associates. 1999. ISBN 1-56592-580-7. </p> </li> </ul></div> <div class="paragraph"><p>Glossaries are optional. Glossaries entries are an example of a style of AsciiDoc labeled lists.</p></div> <div class="dlist glossary"><dl> <dt> A glossary term </dt> <dd> <p> The corresponding (indented) definition. </p> </dd> <dt> A second glossary term </dt> <dd> <p> The corresponding (indented) definition. </p> </dd> </dl></div> <div class="paragraph"><p>Text at the end of a book describing facts about its production.</p></div> ~~</div></div>~~ </div> </div> </div> </div> </div> <div id="footnotes"><hr /></div> <div id="footer"> <div id="footer-text"> Version 1.0<br /> ~~Last updated 2014-02-1~~8 07~~:2~~4:4~~8 MST~~ </div> </div> </body> </html>	\| \| < \| < < < < \| \| < \| < < < < > > \| < < < < < < < < < < \| \| \| \| > > \| < > \| \| > > > \| \| \| > > \| > \| \| \| > > \| \| > > > > > > \| > > > \| \| > > > \| \| \| \| \| > > > \| > > > > > > \| > > > \| \| > > > \| > > > \| \| > > > > \| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < > > > \|	953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 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 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361	<h2 id="_tricks">Tricks</h2> <div class="sectionbody"> <div class="paragraph"><p>This section is a compendium of a various useful tricks for debugging, configuring and generally getting the most out of Megatest.</p></div> </div> </div> <div class="sect1"> <h2 id="_limiting_your_running_jobs">Limiting your running jobs</h2> <div class="sectionbody"> <div class="paragraph"><p>The following example will limit a test in the jobgroup "group1" to no more than 10 tests simultaneously.</p></div> <div class="paragraph"><p>In your testconfig:</p></div> <div class="listingblock"> <div class="content"> <pre><code>[test_meta] jobgroup group1</code></pre> </div></div> <div class="paragraph"><p>In your megatest.config:</p></div> <div class="listingblock"> <div class="content"> <pre><code>[jobgroups] group1 10 custdes 4</code></pre> </div></div> </div> </div> <div class="sect1"> <h2 id="_debugging_tricks">Debugging Tricks</h2> <div class="sectionbody"> <div class="sect2"> <h3 id="_examining_the_environment">Examining The Environment</h3> <div class="sect3"> <h4 id="_during_config_file_processing">During Config File Processing</h4> </div> <div class="sect3"> <h4 id="_organising_your_tests_and_tasks">Organising Your Tests and Tasks</h4> <div class="listingblock"> <div class="content"> <pre><code>[tests-paths] 1 #{get misc parent}/simplerun/tests</code></pre> </div></div> <div class="listingblock"> <div class="content"> <pre><code>[setup]</code></pre> </div></div> <div class="paragraph"><p>The runscript method is a brute force way to run scripts where the user is responsible for setting STATE and STATUS</p></div> <div class="listingblock"> <div class="content"> <pre><code>runscript main.csh</code></pre> </div></div> </div> </div> <div class="sect2"> <h3 id="_debugging_server_problems">Debugging Server Problems</h3> <div class="listingblock"> <div class="content"> <pre><code>sudo lsof -i sudo netstat -lptu sudo netstat -tulpn</code></pre> </div></div> </div> </div> </div> <h1 id="_reference">Reference</h1> <div class="sect1"> <h2 id="_the_testconfig_file">The testconfig File</h2> <div class="sectionbody"> <div class="sect2"> <h3 id="_setup_section">Setup section</h3> <div class="sect3"> <h4 id="_header">Header</h4> <div class="listingblock"> <div class="content"> <pre><code>[setup]</code></pre> </div></div> <div class="paragraph"><p>The runscript method is a brute force way to run scripts where the user is responsible for setting STATE and STATUS</p></div> <div class="listingblock"> <div class="content"> <pre><code>runscript main.csh</code></pre> </div></div> </div> </div> <div class="sect2"> <h3 id="_requirements_section">Requirements section</h3> <div class="sect3"> <h4 id="_header_2">Header</h4> <div class="listingblock"> <div class="content"> <pre><code>[requirements]</code></pre> </div></div> </div> <div class="sect3"> <h4 id="_wait_on_other_tests">Wait on Other Tests</h4> <div class="listingblock"> <div class="content"> <pre><code># A normal waiton waits for the prior tests to be COMPLETED # and PASS, CHECK or WAIVED waiton test1 test2</code></pre> </div></div> </div> <div class="sect3"> <h4 id="_mode">Mode</h4> <div class="paragraph"><p>The default (i.e. if mode is not specified) is normal. All pre-dependent tests must be COMPLETED and PASS, CHECK or WAIVED before the test will start</p></div> <div class="listingblock"> <div class="content"> <pre><code>mode normal</code></pre> </div></div> <div class="paragraph"><p>The toplevel mode requires only that the prior tests are COMPLETED.</p></div> <div class="listingblock"> <div class="content"> <pre><code>mode toplevel</code></pre> </div></div> <div class="paragraph"><p>A item based waiton will start items in a test when the same-named item is COMPLETED and PASS, CHECK or WAIVED in the prior test</p></div> <div class="listingblock"> <div class="content"> <pre><code>mode itemmatch</code></pre> </div></div> <div class="listingblock"> <div class="content"> <pre><code># With a toplevel test you may wish to generate your list # of tests to run dynamically # # waiton #{shell get-valid-tests-to-run.sh}</code></pre> </div></div> </div> <div class="sect3"> <h4 id="_run_time_limit">Run time limit</h4> <div class="listingblock"> <div class="content"> <pre><code>runtimelim 1h 2m 3s # this will automatically kill the test if it runs for more than 1h 2m and 3s</code></pre> </div></div> </div> <div class="sect3"> <h4 id="_skip">Skip</h4> </div> <div class="sect3"> <h4 id="_header_3">Header</h4> <div class="listingblock"> <div class="content"> <pre><code>[skip]</code></pre> </div></div> </div> <div class="sect3"> <h4 id="_skip_on_still_running_tests">Skip on Still-running Tests</h4> <div class="listingblock"> <div class="content"> <pre><code># NB// If the prevrunning line exists with any value the test will # automatically SKIP if the same-named test is currently RUNNING prevrunning x</code></pre> </div></div> </div> <div class="sect3"> <h4 id="_skip_if_a_file_exists">Skip if a File Exists</h4> <div class="listingblock"> <div class="content"> <pre><code>fileexists /path/to/a/file # skip if /path/to/a/file exists</code></pre> </div></div> </div> <div class="sect3"> <h4 id="_controlled_waiver_propagation">Controlled waiver propagation</h4> <div class="paragraph"><p>If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig: If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED</p></div> <div class="paragraph"><p>Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined)</p></div> <div class="listingblock"> <div class="content"> <pre><code>###### EXAMPLE FROM testconfig ######### # matching file(s) will be diff'd with previous run and logpro applied # if PASS or WARN result from logpro then WAIVER state is set # [waivers] # logpro_file rulename input_glob waiver_1 logpro lookittmp.log [waiver_rules] # This builtin rule is the default if there is no <waivername>.logpro file # diff diff %file1% %file2% # This builtin rule is applied if a <waivername>.logpro file exists # logpro diff %file1% %file2% \| logpro %waivername%.logpro %waivername%.html</code></pre> </div></div> </div> </div> <div class="sect2"> <h3 id="_ezsteps">Ezsteps</h3> <div class="paragraph"><p>To transfer the environment to the next step you can do the following:</p></div> <div class="listingblock"> <div class="content"> <pre><code>$MT_MEGATEST -env2file .ezsteps/${stepname}</code></pre> </div></div> </div> <div class="sect2"> <h3 id="_triggers">Triggers</h3> <div class="paragraph"><p>In your testconfig triggers can be specified</p></div> <div class="listingblock"> <div class="content"> <pre><code>[triggers] # Call script running.sh when test goes to state=RUNNING, status=PASS RUNNING/PASS running.sh # Call script running.sh any time state goes to RUNNING RUNNING/ running.sh # Call script onpass.sh any time status goes to PASS PASS/ onpass.sh</code></pre> </div></div> <div class="paragraph"><p>Scripts called will have; test-id test-rundir trigger, added to the commandline.</p></div> <div class="paragraph"><p>HINT</p></div> <div class="paragraph"><p>To start an xterm (useful for debugging), use a command line like the following:</p></div> <div class="listingblock"> <div class="content"> <pre><code>[triggers] COMPLETED/ xterm -e bash -s --</code></pre> </div></div> <div class="admonitionblock"> <table><tr> <td class="icon"> <div class="title">Note</div> </td> <td class="content">There is a trailing space after the --</td> </tr></table> </div> </div> </div> </div> <div class="sect1"> <h2 id="_programming_api">Programming API</h2> <div class="sectionbody"> <div class="paragraph"><p>These routines can be called from the megatest repl.</p></div> <div class="tableblock"> <table rules="all" width="70%" frame="hsides" cellspacing="0" cellpadding="4"> <caption class="title">Table 2. API Server Management Calls</caption> <col width="14%" /> <col width="28%" /> <col width="28%" /> <col width="28%" /> <thead> <tr> <th align="center" valign="top">API Call </th> <th align="left" valign="top"> Purpose comments </th> <th align="left" valign="top"> Returns </th> <th align="left" valign="top"> Comments</th> </tr> </thead> <tfoot> <tr> <td align="center" valign="top"><p class="table">(rmt:login run-id)</p></td> <td align="left" valign="top"><p class="table"><code>Verify the the version, testsuite area etc. are correct.</code></p></td> <td align="left" valign="top"><p class="table"><code>#( #t "successful login" )</code></p></td> <td align="left" valign="top"><p class="table"><code></code></p></td> </tr> </tfoot> <tbody> <tr> <td align="center" valign="top"><p class="table">(rmt:start-server run-id)</p></td> <td align="left" valign="top"><p class="table"><code></code></p></td> <td align="left" valign="top"><p class="table"><code>#( success/fail n/a )</code></p></td> <td align="left" valign="top"><p class="table"><code></code></p></td> </tr> <tr> <td align="center" valign="top"><p class="table">(rmt:kill-server run-id)</p></td> <td align="left" valign="top"><p class="table"><code></code></p></td> <td align="left" valign="top"><p class="table"><code>#( success/fail n/a )</code></p></td> <td align="left" valign="top"><p class="table"><code>Works only if the server is still reachable</code></p></td> </tr> </tbody> </table> </div> <div class="tableblock"> <table rules="all" width="70%" frame="hsides" cellspacing="0" cellpadding="4"> <caption class="title">Table 3. API Keys Related Calls</caption> <col width="14%" /> <col width="28%" /> <col width="28%" /> <col width="28%" /> <thead> <tr> <th align="center" valign="top">API Call </th> <th align="left" valign="top"> Purpose comments </th> <th align="left" valign="top"> Returns </th> <th align="left" valign="top"> Comments</th> </tr> </thead> <tfoot> <tr> <td align="center" valign="top"><p class="table">(rmt:get-key-val-pairs run-id)</p></td> <td align="left" valign="top"><p class="table"><code></code></p></td> <td align="left" valign="top"><p class="table"><code>#t=success/#f=fail</code></p></td> <td align="left" valign="top"><p class="table"><code>Works only if the server is still reachable</code></p></td> </tr> </tfoot> <tbody> <tr> <td align="center" valign="top"><p class="table">(rmt:get-keys run-id)</p></td> <td align="left" valign="top"><p class="table"><code></code></p></td> <td align="left" valign="top"><p class="table"><code>( key1 key2 … )</code></p></td> <td align="left" valign="top"><p class="table"><code></code></p></td> </tr> </tbody> </table> </div> <div class="sect2"> <h3 id="_megatest_internals">Megatest Internals</h3> <div class="imageblock graphviz"> <div class="content"> <img src="server.png" alt="server.png" /> </div> </div> </div> </div> </div> <div class="sect1"> <h2 id="_example_appendix">Appendix A: Example Appendix</h2> <div class="sectionbody"> <div class="paragraph"><p>One or more optional appendixes go here at section level zero.</p></div> <div class="sect2"> <h3 id="_appendix_sub_section">Appendix Sub-section</h3> <div class="admonitionblock"> <table><tr> <td class="icon"> <div class="title">Note</div> </td> <td class="content">Preface and appendix subsections start out of sequence at level 2 (level 1 is skipped). This only applies to multi-part book documents.</td> </tr></table> </div> </div> </div> </div> <div class="sect1"> <h2 id="_example_bibliography">Example Bibliography</h2> <div class="sectionbody"> <div class="paragraph"><p>The bibliography list is a style of AsciiDoc bulleted list.</p></div> <div class="ulist bibliography"><ul> <li> <p> <a id="taoup"></a>[taoup] Eric Steven Raymond. <em>The Art of Unix Programming</em>. Addison-Wesley. ISBN 0-13-142901-9. </p> </li> <li> <p> <a id="walsh-muellner"></a>[walsh-muellner] Norman Walsh & Leonard Muellner. <em>DocBook - The Definitive Guide</em>. O’Reilly & Associates. 1999. ISBN 1-56592-580-7. </p> </li> </ul></div> </div> </div> <div class="sect1"> <h2 id="_example_glossary">Example Glossary</h2> <div class="sectionbody"> <div class="paragraph"><p>Glossaries are optional. Glossaries entries are an example of a style of AsciiDoc labeled lists.</p></div> <div class="dlist glossary"><dl> <dt> A glossary term </dt> <dd> <p> The corresponding (indented) definition. </p> </dd> <dt> A second glossary term </dt> <dd> <p> The corresponding (indented) definition. </p> </dd> </dl></div> </div> </div> <div class="sect1"> <h2 id="_example_colophon">Example Colophon</h2> <div class="sectionbody"> <div class="paragraph"><p>Text at the end of a book describing facts about its production.</p></div> </div> </div> <div class="sect1"> <h2 id="_example_index">Example Index</h2> <div class="sectionbody"> </div> </div> </div> <div id="footnotes"><hr /></div> <div id="footer"> <div id="footer-text"> Version 1.0<br /> Last updated 2014-11-25 21:11:28 MST </div> </div> </body> </html>

︙			︙
13 14 15 16 17 18 19 20 21 22 23 24 25 26	(use sxml-modifications) (use regex) (use srfi-69) (use regex-case) (use posix) (use json) (use csv) (include "../megatest-fossil-hash.scm") ;; Read a non-compressed gnumeric file (define (refdb:read-gnumeric-xml fname) (with-input-from-file fname (lambda ()	>	13 14 15 16 17 18 19 20 21 22 23 24 25 26 27	(use sxml-modifications) (use regex) (use srfi-69) (use regex-case) (use posix) (use json) (use csv) (use srfi-18) (include "../megatest-fossil-hash.scm") ;; Read a non-compressed gnumeric file (define (refdb:read-gnumeric-xml fname) (with-input-from-file fname (lambda ()
︙			︙
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	(hash-table-ref/default cols colname '())))))))) cells) (let ((ref-colnums (map (lambda (c) (list (cdr c)(car c))) (hash-table->alist colnums)))) (with-output-to-file (conc targdir "/" sheet-name ".dat") (lambda () ~~(print "[" col0title "]")~~ (for-each (lambda (colname) (print "[" colname "]") (for-each (lambda (row) (let ((key (car row)) (val (cadr row))) (if (string-search comment-rx key) (print val) (if (string-search blank-rx key) (print) ~~(print key " " val)))))~~ (reverse (hash-table-ref cols colname))) ;; (print) ) (sort (hash-table-keys cols)(lambda (a b) (let ((colnum-a (assoc a ref-colnums)) (colnum-b (assoc b ref-colnums))) (if (and colnum-a colnum-b)	\| > > \|	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	(hash-table-ref/default cols colname '())))))))) cells) (let ((ref-colnums (map (lambda (c) (list (cdr c)(car c))) (hash-table->alist colnums)))) (with-output-to-file (conc targdir "/" sheet-name ".dat") (lambda () (if (not (string-null? col0title))(print "[" col0title "]")) (for-each (lambda (colname) (print "[" colname "]") (for-each (lambda (row) (let ((key (car row)) (val (cadr row))) (if (string-search comment-rx key) (print val) (if (string-search blank-rx key) (print) (if (string-search " " key) (print "\"" key "\" " val) (print key " " val)))))) (reverse (hash-table-ref cols colname))) ;; (print) ) (sort (hash-table-keys cols)(lambda (a b) (let ((colnum-a (assoc a ref-colnums)) (colnum-b (assoc b ref-colnums))) (if (and colnum-a colnum-b)
︙			︙
214 215 216 217 218 219 220 221 222 223 224 225 226 227	(define (hash-table-reverse-lookup ht val) (hash-table-fold ht (lambda (k v res)(if (equal? v val) k res)) #f)) (define (read-dat fname) (let ((section-rx (regexp "^\\[(.)\\]\\s$")) (comment-rx (regexp "^#.")) ;; This means a cell name cannot start with # (cell-rx (regexp "^(\\S+) (.)$")) ;; One space only for the cellname content separator (blank-rx (regexp "^\\s$")) (continue-rx (regexp ".\\\\$")) (var-no-val-rx (regexp "^(\\S+)\\s*$")) (inp (open-input-file fname)) (cmnt-indx (make-hash-table)) (blnk-indx (make-hash-table))	>	217 218 219 220 221 222 223 224 225 226 227 228 229 230 231	(define (hash-table-reverse-lookup ht val) (hash-table-fold ht (lambda (k v res)(if (equal? v val) k res)) #f)) (define (read-dat fname) (let ((section-rx (regexp "^\\[(.)\\]\\s$")) (comment-rx (regexp "^#.")) ;; This means a cell name cannot start with # (quoted-cell-rx (regexp "^\"([^\"])\" (.)$")) (cell-rx (regexp "^(\\S+) (.)$")) ;; One space only for the cellname content separator (blank-rx (regexp "^\\s$")) (continue-rx (regexp ".\\\\$")) (var-no-val-rx (regexp "^(\\S+)\\s*$")) (inp (open-input-file fname)) (cmnt-indx (make-hash-table)) (blnk-indx (make-hash-table))
︙			︙
249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274	(cons (list (conc "#BLNK" curr-indx) section " ") res)))) (section-rx (x sname) (begin (if (not first-section) (set! first-section sname)) (loop (read-line inp) sname res))) (cell-rx (x k v) (loop (read-line inp) section (cons (list k section v) res))) (var-no-val-rx (x k) (loop (read-line inp) section (cons (list k section "") res))) (else (begin (print "ERROR: Unrecognised line in input file " fname ", ignoring it") (loop (read-line inp) section res)))))))) (define (get-value-type val expressions) (cond ((string->number val) '(ValueType "40")) ((equal? val "") '(ValueType "60")) ((equal? (substring val 0 1) "=") (let ((exid (hash-table-ref/default expressions val #f))) (if exid (list 'ExprID exid) (let* ((values (hash-table-keys expressions)) ;; note, values are the id numbers	> > > >	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 279 280 281 282	(cons (list (conc "#BLNK" curr-indx) section " ") res)))) (section-rx (x sname) (begin (if (not first-section) (set! first-section sname)) (loop (read-line inp) sname res))) (quoted-cell-rx (x k v)(loop (read-line inp) section (cons (list k section v) res))) (cell-rx (x k v) (loop (read-line inp) section (cons (list k section v) res))) (var-no-val-rx (x k) (loop (read-line inp) section (cons (list k section "") res))) (else (begin (print "ERROR: Unrecognised line in input file " fname ", ignoring it") (loop (read-line inp) section res)))))))) (define (get-value-type val expressions) (cond ((not val) '(ValueType "60")) ((string->number val) '(ValueType "40")) ((equal? val "") '(ValueType "60")) ((equal? (substring val 0 1) "=") (let ((exid (hash-table-ref/default expressions val #f))) (if exid (list 'ExprID exid) (let* ((values (hash-table-keys expressions)) ;; note, values are the id numbers
︙			︙
452 453 454 455 456 457 458 ~~459~~ ~~460~~ ~~461~~ 462 463 464 465 466 467 468	(print) (print "Don't forget to remove the old files from your revision control system and add the new.") (exit))) (let* ((dbname (pathname-strip-directory path)) (tmpf (conc (create-temporary-file dbname) ".gnumeric"))) (if (file-exists? (conc path "/sheet-names.cfg")) (refdb-export path tmpf)) ~~(let ((pid (process-run "gnumeric" (list tmpf))))~~ ~~(process-wait pid)~~ ~~(import-gnumeric-file tmpf path))))~~ ;;====================================================================== ;; This routine dispaches or executes most of the commands for refdb ;;====================================================================== ;; (define (process-action action-str . param) (let ((num-params (length param))	\| > \| > > > > > > \| > > > > > > > > >	460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492	(print) (print "Don't forget to remove the old files from your revision control system and add the new.") (exit))) (let* ((dbname (pathname-strip-directory path)) (tmpf (conc (create-temporary-file dbname) ".gnumeric"))) (if (file-exists? (conc path "/sheet-names.cfg")) (refdb-export path tmpf)) (let* ((pid (process-run "gnumeric" (list tmpf)))) (let loop ((last-mod-time (current-seconds))) (let-values (((pid-code exit-status exit-signal)(process-wait pid #t))) (if (eq? pid-code 0) ;; still going (if (file-exists? tmpf) (let ((mod-time (file-modification-time tmpf))) (if (> mod-time last-mod-time) (begin (print "saved data to " path) (import-gnumeric-file tmpf path))) (thread-sleep! 0.5) (loop mod-time)) (begin (thread-sleep! 0.5) (loop last-mod-time)))))) ;; all done (print "all done, writing new data to " path) (import-gnumeric-file tmpf path) (print "data written, exiting refdb edit.")))) ;;====================================================================== ;; This routine dispaches or executes most of the commands for refdb ;;====================================================================== ;; (define (process-action action-str . param) (let ((num-params (length param))
︙			︙

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	#!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq (use regex srfi-69 srfi-13) (define targs #f) (define files (cddddr (argv))) (let ((targdat (cadddr (argv)))) (if (equal? targdat "-") (set! targs files) (set! targs (string-split targdat ",")))) (define filedat-defns (make-hash-table)) (define filedat-usages (make-hash-table)) (define defn-rx (regexp "^\\s\\(define\\s+\\(([^\\s\\)]+).")) (define all-regexs (make-hash-table)) (define all-fns '()) (define (print-err . data) (with-output-to-port (current-error-port) (lambda () (apply print data)))) (print-err "Making graph for files: " (string-intersperse targs ", "))	> > > > > > > > >	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	#!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq ;; Coming soon (right?) Usage: plot-code file1.scm,file2.scm "fun1,fun2,x" .scm > plot.dot ;; Usage: plot-code file1.scm,file2.scm .scm > plot.dot ;; dot -Tpdf plot.dot > plot.pdf ;; first param is comma separated list of files to include in the map, use - to do all ;; second param is list of regexs for functions to include in the map ;; third param is list of files to scan (use regex srfi-69 srfi-13) (define targs #f) (define files (cddddr (argv))) (let ((targdat (cadddr (argv)))) (if (equal? targdat "-") (set! targs files) (set! targs (string-split targdat ",")))) (define filedat-defns (make-hash-table)) (define filedat-usages (make-hash-table)) (define defn-rx (regexp "^\\s\\(define\\s+\\(([^\\s\\)]+).*")) (define all-regexs (make-hash-table)) (define all-fns '()) ;; for the se (define (print-err . data) (with-output-to-port (current-error-port) (lambda () (apply print data)))) (print-err "Making graph for files: " (string-intersperse targs ", "))
︙			︙
79 80 81 82 83 84 85 86 87 88 89 90 91 92 93	(loop (car tal) (cdr tal) newres))) (if (null? tal) res (loop (car tal)(cdr tal) res))))) '())) ;; Gather the usages (print "digraph G {") (define curr-cluster-num 0) (define function-calls '()) (for-each (lambda (fname)	\| > > > > > > > > > > > > > > > > > > > > >	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	(loop (car tal) (cdr tal) newres))) (if (null? tal) res (loop (car tal)(cdr tal) res))))) '())) ;; (define mm-header #<<MMHEADER ;; <map version="freeplane 1.2.0"> ;; <!--To view this file, download free mind mapping software Freeplane from http://freeplane.sourceforge.net --> ;; ;; MMHEADER ;; ;; (define (add-node text) ;; <node TEXT="homenode" ID="ID_1723255651" CREATED="1283093380553" MODIFIED="1417113442955"><hook NAME="MapStyle"> ;; ) ;; ;; minimal mindmap file ;; <map version="freeplane 1.2.0"> ;; <!--To view this file, download free mind mapping software Freeplane from http://freeplane.sourceforge.net --> ;; <node TEXT="homenode" ID="ID_1723255651" CREATED="1283093380553" MODIFIED="1417113442955"> ;; <node TEXT="node1" POSITION="right" ID="ID_1810107939" CREATED="1417113473476" MODIFIED="1417113480425"> ;; <node TEXT="node2" ID="ID_68133256" CREATED="1417113482134" MODIFIED="1417113484466"/> ;; <node TEXT="node3" ID="ID_1572284821" CREATED="1417113487785" MODIFIED="1417113491589"/> ;; </node> ;; </node> ;; </map> ;; Gather the usages (print "digraph G {") (define curr-cluster-num 0) (define function-calls '()) (for-each (lambda (fname)
︙			︙