This is equivalent to a diff from
c6761db385
to 6a50f08af8
Modified Makefile
from [2a43e569cb]
to [12acad184c].
| ︙ | | |
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
|
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
|
-
-
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
+
-
-
+
+
+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
#
# You should have received a copy of the GNU General Public License
# along with Megatest. If not, see <http://www.gnu.org/licenses/>.
# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
# rm <files>.o ; make install CSCOPTS='-profile' ; ... ; chicken-profile | less
SHELL=/bin/bash
PREFIX=$(PWD)
CSCOPTS=
PREFIX=$(PWD)/tmpinstall
INSTALL=install
SRCFILES = common.scm items.scm launch.scm \
ods.scm runconfig.scm server.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 tdb.scm \
client.scm mt.scm \
ezsteps.scm lock-queue.scm sdb.scm \
rmt.scm api.scm subrun.scm \
portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm
# module source files
MSRCFILES = ftail.scm
# mtcommon.scm mtdb.scm mtconfigf.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-context-menu.scm dashboard-tests.scm dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm vg.scm
OFILES = $(SRCFILES:%.scm=%.o)
GOFILES = $(GUISRCF:%.scm=%.o)
MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
MOFILES = $(MSRCFILES:%.scm=%.o)
mofiles/%.o : %.scm
mkdir -p mofiles
csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut
all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut eggs
mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o
mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) $(MTEGGS)
csc $(CSCOPTS) $(OFILES) $(MOFILES) megatest.o -o mtest
showmtesthash:
@echo $(MTESTHASH)
dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES)
csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) -o dboard
ndboard : newdashboard.scm $(OFILES) $(GOFILES)
csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard
mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm
csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut
|
| ︙ | | |
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
-
+
+
|
rpc-transport.o \
runconfig.o \
runs.o \
server.o \
tasks.o \
tdb.o \
tests.o \
subrun.o \
subrun.o
# mtconfigf.o
tcmt : $(TCMTOBJS) tcmt.scm
csc $(CSCOPTS) $(TCMTOBJS) tcmt.scm -o tcmt
# install documentation to $(PREFIX)/docs
# DOES NOT REBUILD DOCS
#
|
| ︙ | | |
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
|
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
|
-
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
|
mkdir -p $(PREFIX)/share/js
fossil wiki export java-script-lib > $(PREFIX)/share/js/jquery-3.1.0.slim.min.js
$(PREFIX)/share/db/mt-pg.sql : mt-pg.sql
mkdir -p $(PREFIX)/share/db
$(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql
#multi-dboard : multi-dboard.scm $(OFILES) $(GOFILES)
# setup the eggs dir in $PREFIX
# csc $(CSCOPTS) $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard
#
# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm
# csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl
rmt.scm client.scm common.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm
rmt.scm client.scm common.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm $(MTEGGS)
common_records.scm : altdb.scm
vg.o dashboard.o : vg_records.scm
dcommon.o : run_records.scm
# Temporary while transitioning to new routine
# runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm
megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm
|
| ︙ | | |
264
265
266
267
268
269
270
271
272
273
274
275
276
277
|
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
|
+
+
|
$(PREFIX)/bin/mtest-reaper: helpers/mtest-reaper.scm helpers/ducttape-lib.scm helpers/inteldate.scm helpers/mimetypes.scm
make -C helpers $@ PREFIX=$(PREFIX) INSTALL=$(INSTALL) ARCHSTR=$(ARCHSTR)
mtest-reaper: $(PREFIX)/bin/mtest-reaper
# install dashboard as dboard so wrapper script can be called dashboard
# NOTE: Should be able to add something like -Wl,'$ORIGIN/../lib' to find IUP libs
#
$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper
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 \
|
| ︙ | | |
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
|
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
|
-
+
+
+
+
|
mkdir -p ext-tests
cd ext-tests;fossil open --nested $(MTQA_FOSSIL)
$(MTQA_FOSSIL) :
fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL)
clean :
rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o
rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest \
$(PREFIX)/dashboard mtest mtutil dboard dboard.o megatest.o dashboard.o \
megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o mtut.o \
*.import.scm mofiles/*.import.scm *.bak *~ *-original *-merge *-baseline
#======================================================================
# Make the records files
#======================================================================
# vg_records.scm : records.sh
# ./records.sh
|
| ︙ | | |
Modified TODO
from [19e430807b]
to [ca19aa8019].
| ︙ | | |
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
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
|
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
# along with Megatest. If not, see <http://www.gnu.org/licenses/>.
TODO
====
. Dashboard should resist running from non-homehost
|
Modified archive.scm
from [618f9a591e]
to [74fa7d453a].
| ︙ | | |
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
-
+
|
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)
(declare (unit archive))
(declare (uses db))
(declare (uses common))
(use (prefix mtconfigf configf:))
(include "common_records.scm")
(include "db_records.scm")
;;======================================================================
;;
;;======================================================================
|
| ︙ | | |
Modified cgisetup/models/pgdb.scm
from [015f5f388e]
to [644c3cf297].
| ︙ | | |
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
|
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
|
-
+
|
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit pgdb))
;; (declare (uses configf))
;;(declare (uses mtconfigf))
(use (prefix mtconfigf configf:))
;; I don't know how to mix compilation units and modules, so no module here.
;;
;; (module pgdb
;; (
;; open-pgdb
|
| ︙ | | |
Modified common.scm
from [8b5ebebcbe]
to [93d84ac7a7].
| ︙ | | |
24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
matchable regex posix (srfi 18) extras ;; tcp
(prefix nanomsg nmsg:)
(prefix sqlite3 sqlite3:)
pkts (prefix dbi dbi:)
)
(declare (unit common))
(use posix-extras pathname-expand files)
;; this plugs a hole in posix-extras in recent chicken versions > 4.9)
(let-values (( (chicken-release-number chicken-major-version)
(apply values
(map string->number
(take
(string-split (chicken-version) ".")
2)))))
(let ((resolve-pathname-broken?
(or (> chicken-release-number 4)
(and (eq? 4 chicken-release-number) (> chicken-major-version 9)))))
(if resolve-pathname-broken?
(define ##sys#expand-home-path pathname-expand))))
(define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) ))
(define (common:get-this-exe-fullpath #!key (argv (argv)))
(let* ((this-script
(cond
((and (> (length argv) 2)
(string-match "^(.*/csi|csi)$" (car argv))
(string-match "^-(s|ss|sx|script)$" (cadr argv)))
(caddr argv))
(else (car argv))))
(fullpath (realpath this-script)))
fullpath))
(define *common:this-exe-fullpath* (common:get-this-exe-fullpath))
(define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*))
(define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*))
(let* ((libpath (conc *common:this-exe-dir* "/../../eggs/lib/chicken/7")))
(if (and (not (get-environment-variable "CHICKEN_REPOSITORY"))
(directory-exists? libpath))
(repository-path libpath)))
;;(declare (uses mtconfigf))
(use (prefix mtconfigf configf:))
;;(configf:add-eval-string "(use common)")
(include "common_records.scm")
;; (require-library margs)
;; (include "margs.scm")
|
| ︙ | | |
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
|
234
235
236
237
238
239
240
241
242
243
244
245
246
247
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget
(define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set
(define *homehost-mutex* (make-mutex))
;; Miscellaneous
(define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers
(use posix-extras pathname-expand files)
;; this plugs a hole in posix-extras in recent chicken versions > 4.9)
(let-values (( (chicken-release-number chicken-major-version)
(apply values
(map string->number
(take
(string-split (chicken-version) ".")
2)))))
(let ((resolve-pathname-broken?
(or (> chicken-release-number 4)
(and (eq? 4 chicken-release-number) (> chicken-major-version 9)))))
(if resolve-pathname-broken?
(define ##sys#expand-home-path pathname-expand))))
(define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) ))
(define (common:get-this-exe-fullpath #!key (argv (argv)))
(let* ((this-script
(cond
((and (> (length argv) 2)
(string-match "^(.*/csi|csi)$" (car argv))
(string-match "^-(s|ss|sx|script)$" (cadr argv)))
(caddr argv))
(else (car argv))))
(fullpath (realpath this-script)))
fullpath))
(define *common:this-exe-fullpath* (common:get-this-exe-fullpath))
(define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*))
(define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*))
|
| ︙ | | |
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
|
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
|
-
+
|
(string-split patts ","))
res)
#t))
;; '(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))
(or configf (configf:read-config "megatest.config" #f #t))
"disks" '("none" "")))
;; return first command that exists, else #f
;;
(define (common:which cmds)
(if (null? cmds)
#f
|
| ︙ | | |
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
|
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
|
-
+
|
;;======================================================================
;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t))))
;;
(define (common:get-runconfig-targets #!key (configf #f))
(let ((targs (sort (map car (hash-table->alist
(or configf ;; NOTE: There is no value in using runconfig:read here.
(read-config (conc *toppath* "/runconfigs.config")
(configf:read-config (conc *toppath* "/runconfigs.config")
#f #t)
(make-hash-table))))
string<?))
(target-patt (args:get-arg "-target")))
(if target-patt
(filter (lambda (x)
(patt-list-match x target-patt))
|
| ︙ | | |
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
|
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
|
-
+
-
+
|
;; first read ~/views.config if it exists, then read $MTRAH/views.config if it exists
;;
(define (common:load-views-config)
(let* ((view-cfgdat (make-hash-table))
(home-cfgfile (conc (get-environment-variable "HOME") "/.mtviews.config"))
(mthome-cfgfile (conc *toppath* "/.mtviews.config")))
(if (common:file-exists? mthome-cfgfile)
(read-config mthome-cfgfile view-cfgdat #t))
(configf:read-config mthome-cfgfile view-cfgdat #t))
;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas
(if (common:file-exists? home-cfgfile)
(read-config home-cfgfile view-cfgdat #t))
(configf:read-config home-cfgfile view-cfgdat #t))
view-cfgdat))
;;======================================================================
;; H I E R A R C H I C A L H A S H T A B L E S
;;======================================================================
;; Every element including top element is a vector:
|
| ︙ | | |
Modified dashboard-context-menu.scm
from [0a1e7c69d9]
to [e20e49dcf1].
| ︙ | | |
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
-
+
|
;; implementation of context menu that pops up on
;; right click on test cell in Runs & Runs Summary Tabs
;;======================================================================
(use format fmt)
(require-library iup)
(import (prefix iup iup:))
(use (prefix mtconfigf configf:))
(use canvas-draw)
(use srfi-1 posix regex regex-case srfi-69)
(use (prefix sqlite3 sqlite3:))
(declare (unit dashboard-context-menu))
(declare (uses common))
|
| ︙ | | |
Modified dashboard-tests.scm
from [2af1eb577e]
to [491c46fe86].
| ︙ | | |
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
-
+
|
;;======================================================================
;; Test info panel
;;======================================================================
(use format fmt)
(require-library iup)
(import (prefix iup iup:))
(use (prefix mtconfigf configf:))
(use canvas-draw)
(use srfi-1 posix regex regex-case srfi-69)
(use (prefix sqlite3 sqlite3:))
(declare (unit dashboard-tests))
(declare (uses common))
|
| ︙ | | |
Modified dashboard.scm
from [a26576c28a]
to [0a9560dd70].
| ︙ | | |
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
|
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
|
-
+
-
+
-
+
+
+
|
;;
;;======================================================================
(use format)
(require-library iup)
(import (prefix iup iup:))
(use (prefix mtconfigf configf:))
(use canvas-draw)
(import canvas-draw-iup)
(use ducttape-lib)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))
(use (prefix mtconfigf configf:))
;; (declare (uses configf))
;;(declare (uses mtconfigf))
(use (prefix mtconfigf configf:))
(declare (uses process))
(declare (uses launch))
(declare (uses runs))
(declare (uses dashboard-tests))
(declare (uses dashboard-guimonitor))
(declare (uses tree))
(declare (uses dcommon))
|
| ︙ | | |
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
|
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
|
-
+
|
;;======================================================================
;; S U M M A R Y
;;======================================================================
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary commondat tabdat #!key (tab-num #f))
(let* ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
(let* ((rawconfig (configf:read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
(changed #f))
(iup:vbox
(iup:split
#:value 300
(iup:frame
#:title "General Info"
(iup:vbox
|
| ︙ | | |
Modified datashare.scm
from [2c1663032f]
to [e0a5e1ca32].
| ︙ | | |
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
|
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
|
-
+
|
(use srfi-18)
(use format)
(require-library iup)
(import (prefix iup iup:))
(require-library ini-file)
(import (prefix ini-file ini:))
(use (prefix mtconfigf configf:))
(use canvas-draw)
(import canvas-draw-iup)
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(declare (uses configf))
|
| ︙ | | |
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
|
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
|
-
+
|
(define (datashare:load-config exe-dir exe-name)
(let* ((fname (conc exe-dir "/." exe-name ".config")))
(ini:property-separator-patt " * *")
(ini:property-separator #\space)
(if (common:file-exists? fname)
;; (ini:read-ini fname)
(read-config fname #f #t)
(configf:read-config fname #f #t)
(make-hash-table))))
(define (datashare:process-action configdat action . args)
(case (string->symbol action)
((get)
(if (< (length args) 2)
(begin
|
| ︙ | | |
Modified db.scm
from [b49a2db6be]
to [379523eb57].
| ︙ | | |
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
|
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
|
-
+
|
(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
(use (prefix mtconfigf configf:))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's
(define *number-of-writes* 0)
|
| ︙ | | |
248
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
|
248
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
275
|
-
+
+
-
+
|
(seconds->year-work-week/day-time
(current-seconds)))))))
db))
(exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
(exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
(exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
(exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
(exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
(exn () (debug:print 0 *default-log-port* "ERROR: (1) Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))
)
(condition-case
(begin
(debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname)
(let ((db (sqlite3:open-database fname)))
;; (mutex-unlock! *db-open-mutex*)
db))
(exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
(exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
(exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
(exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
(exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
(exn () (debug:print 0 *default-log-port* "ERROR: (2) Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
)))
|
| ︙ | | |
Modified dcommon.scm
from [2d492dcb7c]
to [bef4006bb5].
| ︙ | | |
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
-
+
|
(declare (unit dcommon))
(declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
;; (declare (uses synchash))
(use (prefix mtconfigf configf:))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
;; yes, this is non-ideal
(define dashboard:update-summary-tab #f)
|
| ︙ | | |
Modified ezsteps.scm
from [80e8d0742f]
to [93cba9d1b6].
| ︙ | | |
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
|
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
|
-
+
-
+
|
(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
;; (declare (uses filedb))
(use (prefix mtconfigf configf:))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(define (ezsteps:run-from testdat start-step-name run-one)
(let* ((test-run-dir ;; (filedb:get-path *fdb*
(db:test-get-rundir testdat)) ;; )
(testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
(testconfig (configf:read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
(ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))
(run-mutex (make-mutex))
(rollup-status 0)
(exit-info (vector #t #t #t))
(test-id (db:test-get-id testdat))
(run-id (db:test-get-run_id testdat))
(test-name (db:test-get-testname testdat))
|
| ︙ | | |
Modified ftail.scm
from [96a7ff77a3]
to [721728b98f].
| ︙ | | |
15
16
17
18
19
20
21
22
23
24
25
26
27
28
|
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
|
+
|
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit ftail))
(module ftail
(
open-tail-db
tail-write
tail-get-fid
file-tail
|
| ︙ | | |
Modified http-transport.scm
from [da311848d8]
to [02c250fb10].
| ︙ | | |
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
-
+
|
(use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing)
;; Configurations for server
(tcp-buffer-size 2048)
(max-connections 2048)
(declare (unit http-transport))
(use (prefix mtconfigf configf:))
(declare (uses common))
(declare (uses db))
(declare (uses tests))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(declare (uses server))
;; (declare (uses daemon))
(declare (uses portlogger))
|
| ︙ | | |
Modified items.scm
from [2265706948]
to [3f34d4881a].
| ︙ | | |
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
-
+
|
;; (define itemdat '((ripeness "green ripe overripe")
;; (temperature "cool medium hot")
;; (season "summer winter fall spring")))
(declare (unit items))
(declare (uses common))
(use (prefix mtconfigf configf:))
(include "common_records.scm")
;; Puts out all combinations
(define (process-itemlist hierdepth curritemkey itemlist)
(let ((res '()))
(if (not hierdepth)
(set! hierdepth (length itemlist)))
|
| ︙ | | |
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
-
+
|
(loop (+ indx 1)
'()
#f)))
res)))
;; Nope, not now, return null as of 6/6/2011
(define (items:check-valid-items class item)
(let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class)))
(let ((valid-values (let ((s (configf:lookup *configdat* "validvalues" class)))
(if s (string-split s) #f))))
(if valid-values
(if (member item valid-values)
item #f)
item)))
(define (items:get-items-from-config tconfig)
|
| ︙ | | |
Modified keys.scm
from [9fa2c0cfa5]
to [5df703db34].
| ︙ | | |
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
-
+
|
;;======================================================================
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(declare (unit keys))
(declare (uses common))
(use (prefix mtconfigf configf:))
(include "key_records.scm")
(include "common_records.scm")
(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
(string-intersperse keys ","))
(define (args:usage . a) #f)
|
| ︙ | | |
Modified launch.scm
from [7a44cc90cf]
to [3e92b38410].
| ︙ | | |
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
|
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
|
-
+
+
+
+
|
;;======================================================================
;; launch a task - this runs on the originating host, tests themselves
;;
;;======================================================================
(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv)
(use typed-records pathname-expand matchable)
(use (prefix mtconfigf configf:))
;; (use (prefix mtconfigf configf:))
(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))
(declare (unit launch))
(declare (uses subrun))
(declare (uses common))
;; (declare (uses configf))
(declare (uses db))
;;(declare (uses mtconfigf))
(use (prefix mtconfigf configf:))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
;;======================================================================
;; ezsteps
;;======================================================================
|
| ︙ | | |
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
|
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
-
+
|
;; return (conc status ": " comment) from the final section so that
;; the comment can be set in the step record in launch.scm
;;
(define (launch:load-logpro-dat run-id test-id stepname)
(let ((cname (conc stepname ".dat")))
(if (common:file-exists? cname)
(let* ((dat (read-config cname #f #f))
(let* ((dat (configf:read-config cname #f #f))
(csvr (db:logpro-dat->csv dat stepname))
(csvt (let-values (((fmt-cell fmt-record fmt-csv) (make-format ",")))
(fmt-csv (map list->csv-record csvr))))
(status (configf:lookup dat "final" "exit-status"))
(msg (configf:lookup dat "final" "message")))
(if csvt ;; this if blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro
(rmt:csv->test-data run-id test-id csvt)
|
| ︙ | | |
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
|
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
|
-
+
|
(change-directory *toppath*)
;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This
;; seems non-ideal but could well break stuff
;; BUG? BUG? BUG?
(let ((rconfig (full-runconfigs-read)) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))))
(wconfig (read-config "waivers.config" #f #t sections: `( "default" ,target )))) ;; read the waivers config if it exists
(wconfig (configf:read-config "waivers.config" #f #t sections: `( "default" ,target )))) ;; read the waivers config if it exists
;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target)
;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id))
;; Now have runconfigs data loaded, set environment vars
(for-each
(lambda (section)
(for-each
(lambda (varval)
|
| ︙ | | |
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
|
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
|
-
+
-
+
|
*toppath*)
;; there are no existing cached configs, do full reads of the configs and cache them
;; we have all the info needed to fully process runconfigs and megatest.config
((and ;; (not force-reread) ;; force-reread is irrelevant in the AND, could however OR it?
mtcachef
rccachef) ;; BB- why are we doing this without asking if caching is desired?
;;(BB> "launch:setup-body -- cond branch 2")
(let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect
(let* ((first-pass (configf:find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect
mtconfig
environ-patt: "env-override"
given-toppath: toppath
pathenvvar: "MT_RUN_AREA_HOME"))
(first-rundat (let ((toppath (if toppath
toppath
(car first-pass))))
(read-config ;; (conc toppath "/runconfigs.config") ;; this should be converted to runconfig:read but it is non-trivial, leaving it for now.
(configf:read-config ;; (conc toppath "/runconfigs.config") ;; this should be converted to runconfig:read but it is non-trivial, leaving it for now.
(conc (if (string? toppath)
toppath
(get-environment-variable "MT_RUN_AREA_HOME"))
"/runconfigs.config")
*runconfigdat* #t
sections: sections))))
(set! *runconfigdat* first-rundat)
|
| ︙ | | |
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
|
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
|
-
+
-
+
|
;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it
(let* ((keys (rmt:get-keys))
(key-vals (keys:target->keyval keys target))
(linktree (common:get-linktree)) ;; (or (getenv "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
; (if *configdat*
; (configf:lookup *configdat* "setup" "linktree")
; (conc *toppath* "/lt"))))
(second-pass (find-and-read-config
(second-pass (configf:find-and-read-config
mtconfig
environ-patt: "env-override"
given-toppath: toppath
pathenvvar: "MT_RUN_AREA_HOME"))
(runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config
(for-each (lambda (kt)
(setenv (car kt) (cadr kt)))
key-vals)
(read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ...
(configf:read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ...
sections: sections)))
(cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig))
(mtcachef (car cachefiles))
(rccachef (cdr cachefiles)))
;; trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "/p/fdk/gwa/lefkowit/mtTesting/qa/primbeqa/links/p1222/11/PDK_r1.1.1/prim/clean/pcell_testgen/.runconfigs.cfg-1.6427-7d1e789cb3f62f9cde719a4865bb51b3c17ea853" - ticket 220546342
;; TODO - consider 1) using simple-lock to bracket cache write
;; 2) cache in hash on server, since need to do rmt: anyway to lock.
|
| ︙ | | |
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
|
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
|
-
+
-
+
|
(set! *configdat* (make-hash-table))
)))
;; else read what you can and set the flag accordingly
;; here we don't have either mtconfig or rccachef
(else
;;(BB> "launch:setup-body -- cond branch 3 - else")
(let* ((cfgdat (find-and-read-config
(let* ((cfgdat (configf:find-and-read-config
(or (args:get-arg "-config") "megatest.config")
environ-patt: "env-override"
given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
pathenvvar: "MT_RUN_AREA_HOME")))
(if (and cfgdat (list? cfgdat) (> (length cfgdat) 0) (hash-table? (car cfgdat)))
(let* ((toppath (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat)))
(rdat (read-config (conc toppath ;; convert this to use runconfig:read!
(rdat (configf:read-config (conc toppath ;; convert this to use runconfig:read!
"/runconfigs.config") *runconfigdat* #t sections: sections)))
(set! *configinfo* cfgdat)
(set! *configdat* (car cfgdat))
(set! *runconfigdat* rdat)
(set! *toppath* toppath)
(set! *configstatus* 'partial))
(begin
|
| ︙ | | |
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
|
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
|
-
+
|
(if (and rccachef mtcachef *runconfigdat* *configdat*)
(set! *configstatus* 'fulldata)))
;; if have -append-config then read and append here
(let ((cfname (args:get-arg "-append-config")))
(if (and cfname
(file-read-access? cfname))
(read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special.
(configf:read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special.
*toppath*)))
(define (get-best-disk confdat testconfig)
(let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f))
(hash-table-ref/default confdat "disks" #f)))
(minspace (let ((m (configf:lookup confdat "setup" "minspace")))
(string->number (or m "10000")))))
|
| ︙ | | |
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
|
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
|
-
+
|
result
(if (null? tail)
(cons 1 (conc *toppath* "/runs"))
(loop (car tail) (cdr tail)))))))))))))) ;; the code creates the necessary directories if it does not exist and returns the path.
(define (launch:test-copy test-src-path test-path)
(let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd")))
(let* ((ovrcmd (let ((cmd (configf:lookup *configdat* "setup" "testcopycmd")))
(if cmd
;; substitute the TEST_SRC_PATH and TEST_TARG_PATH
(string-substitute "TEST_TARG_PATH" test-path
(string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t)
#f)))
(cmd (if ovrcmd
ovrcmd
|
| ︙ | | |
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
|
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
|
-
+
|
;; nb// if itempath is not "" then it is prefixed with "/"
(toptest-path (conc disk-path (if contour (conc "/" contour) "") "/" testtop-base))
(test-path (conc disk-path (if contour (conc "/" contour) "") "/" test-base))
;; ensure this exists first as links to subtests must be created there
(linktree (common:get-linktree))
;; WAS: (let ((rd (config-lookup *configdat* "setup" "linktree")))
;; WAS: (let ((rd (configf:lookup *configdat* "setup" "linktree")))
;; (if rd rd (conc *toppath* "/runs"))))
;; which seems wrong ...
(lnkbase (conc linktree (if contour (conc "/" contour) "") "/" target "/" runname))
(lnkpath (conc lnkbase "/" testname))
(lnkpathf (conc lnkpath (if not-iterated "" "/") item-path))
(lnktarget (conc lnkpath "/" item-path)))
|
| ︙ | | |
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
|
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
|
-
+
-
+
-
-
-
-
+
+
+
+
-
+
|
itemdat))
(let* ((tregistry (tests:get-all)) ;; third param (below) is system-allowed
;; for tconfig, why do we allow fallback to test-conf?
(tconfig (or (tests:get-testconfig test-name item-path tregistry #t force-create: #t)
(begin
(debug:print 0 *default-log-port* "WARNING: falling back to pre-calculated testconfig. This is likely not desired.")
test-conf))) ;; force re-read now that all vars are set
(useshell (let ((ush (config-lookup *configdat* "jobtools" "useshell")))
(useshell (let ((ush (configf:lookup *configdat* "jobtools" "useshell")))
(if ush
(if (equal? ush "no") ;; must use "no" to NOT use shell
#f
ush)
#t))) ;; default is yes
(runscript (config-lookup tconfig "setup" "runscript"))
(runscript (configf:lookup tconfig "setup" "runscript"))
(ezsteps (> (length (hash-table-ref/default tconfig "ezsteps" '())) 0)) ;; don't send all the steps, could be big, just send a flag
(subrun (> (length (hash-table-ref/default tconfig "subrun" '())) 0)) ;; send a flag to process a subrun
;; (diskspace (config-lookup tconfig "requirements" "diskspace"))
;; (memory (config-lookup tconfig "requirements" "memory"))
;; (hosts (config-lookup *configdat* "jobtools" "workhosts")) ;; I'm pretty sure this was never completed
(remote-megatest (config-lookup *configdat* "setup" "executable"))
;; (diskspace (configf:lookup tconfig "requirements" "diskspace"))
;; (memory (configf:lookup tconfig "requirements" "memory"))
;; (hosts (configf:lookup *configdat* "jobtools" "workhosts")) ;; I'm pretty sure this was never completed
(remote-megatest (configf:lookup *configdat* "setup" "executable"))
(run-time-limit (or (configf:lookup tconfig "requirements" "runtimelim")
(configf:lookup *configdat* "setup" "runtimelim")))
;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to
;; allow running from dashboard. Extract the path
;; from the called megatest and convert dashboard
;; or dboard to megatest
(local-megatest (let* ((lm (car (argv)))
(dir (pathname-directory lm))
(exe (pathname-strip-directory lm)))
(conc (if dir (conc dir "/") "")
(case (string->symbol exe)
((dboard) "../megatest")
((mtest) "../megatest")
((dashboard) "megatest")
(else exe)))))
(launcher (common:get-launcher *configdat* test-name item-path)) ;; (config-lookup *configdat* "jobtools" "launcher"))
(launcher (common:get-launcher *configdat* test-name item-path)) ;; (configf:lookup *configdat* "jobtools" "launcher"))
(test-sig (conc (common:get-testsuite-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path
(work-area #f)
(toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all
(diskpath #f)
(cmdparms #f)
(fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x))))
(mt-bindir-path #f)
|
| ︙ | | |
Modified megatest.scm
from [cecad5eaf2]
to [7c5c594706].
| ︙ | | |
51
52
53
54
55
56
57
58
59
60
61
62
63
64
|
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
|
+
+
|
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
(declare (uses ftail))
(import ftail)
;;(declare (uses mtconfigf))
(use (prefix mtconfigf configf:))
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
|
| ︙ | | |
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
|
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
|
+
+
+
+
+
-
+
|
(runscript (assoc/default 'runscript cmdinfo))
(db-host (assoc/default 'db-host cmdinfo))
(run-id (assoc/default 'run-id cmdinfo))
(test-id (assoc/default 'test-id cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(work-area (assoc/default 'work-area cmdinfo))
(db #f))
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "ERROR: the work directory " testpath " has disappeared or become unreadable! Cannot proceed, exiting now.")
(exit 1))
(change-directory testpath)
(change-directory testpath))
(if (not (launch:setup))
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
(if (and state status)
(let ((comment (launch:load-logpro-dat run-id test-id step)))
;; (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
|
| ︙ | | |
Modified mt.scm
from [3cc1b8b1ff]
to [8a3c309dad].
| ︙ | | |
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
-
+
|
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses runs))
(declare (uses rmt))
;; (declare (uses filedb))
(use (prefix mtconfigf configf:))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
;; This is the Megatest API. All generally "useful" routines will be wrapped or extended
|
| ︙ | | |
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
|
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
|
-
+
|
;; Setting MT_LINKTREE here is almost certainly unnecessary.
(let ((tconfig-file (conc hed "/" test-name "/testconfig")))
(if (and (common:file-exists? tconfig-file)
(file-read-access? tconfig-file))
(let ((link-tree-path (common:get-linktree)) ;; (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 ...]
(let ((newtcfg (configf: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-error 0 *default-log-port* "No readable testconfig found for " test-name)
#f)
(loop (car tal)(cdr tal))))))))))
|
Modified mtut.scm
from [50be2de849]
to [8cda2487c9].
| ︙ | | |
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
|
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
|
-
-
+
+
+
-
+
-
-
-
+
+
+
+
+
|
;; (include "common.scm")
;; (include "megatest-version.scm")
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
srfi-19 srfi-18 extras format pkts regex regex-case
(use srfi-1 posix srfi-69 readline
srfi-19 srfi-18 extras format
pkts regex regex-case
(prefix dbi dbi:)
nanomsg
nanomsg)
(prefix mtconfigf configf:))
;; (declare (uses configf))
;; (declare (uses rmt))
;; (declare (uses rmt))
;; mtconfigf is compiled in as a compilation unit
;;(declare (uses mtconfigf))
(use (prefix mtconfigf configf:))
(use ducttape-lib)
(include "megatest-fossil-hash.scm")
(require-library stml)
|
| ︙ | | |
Modified newdashboard.scm
from [3cc17ecae4]
to [cd3f5d9917].
| ︙ | | |
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
-
+
|
(use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct
(prefix dbi dbi:))
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(use (prefix mtconfigf configf:))
;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses server))
;; (declare (uses synchash))
(declare (uses dcommon))
;; (declare (uses tree))
|
| ︙ | | |
Modified portlogger.scm
from [8b8ee119e5]
to [14da9d63cf].
| ︙ | | |
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
|
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
|
-
+
|
(require-extension (srfi 18) extras tcp s11n)
(use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3)
(import (prefix sqlite3 sqlite3:))
(declare (unit portlogger))
(declare (uses db))
(use (prefix mtconfigf configf:))
;; lsof -i
(define (portlogger:open-db fname)
(let* ((avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
(exists (common:file-exists? fname))
(db (if avail
|
| ︙ | | |
Modified rpc-transport.scm
from [dd887f94ec]
to [69299fdeaf].
| ︙ | | |
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
|
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
|
-
+
|
(declare (unit rpc-transport))
(declare (uses common))
(declare (uses db))
(declare (uses tests))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(use (prefix mtconfigf configf:))
(include "common_records.scm")
(include "db_records.scm")
;; procstr is the name of the procedure to be called as a string
(define (rpc-transport:autoremote procstr params)
(handle-exceptions
exn
|
| ︙ | | |
Modified runconfig.scm
from [66b9c38588]
to [b51358d392].
| ︙ | | |
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
-
+
-
+
|
;; to this run field1val/field2val/field3val ...
;;======================================================================
(use format directory-utils)
(declare (unit runconfig))
(declare (uses common))
(use (prefix mtconfigf configf:))
(include "common_records.scm")
(define (runconfig:read fname target environ-patt)
(let ((ht (make-hash-table)))
(if target (hash-table-set! ht target '()))
(read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f))))
(configf:read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f))))
;; NB// to process a runconfig ensure to use environ-patt with target!
;;
(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)) "/")
|
| ︙ | | |
Modified runs.scm
from [18e897116f]
to [072a77db1a].
| ︙ | | |
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
-
+
|
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses mt))
(declare (uses archive))
;; (declare (uses filedb))
(use (prefix mtconfigf configf:))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
;; (include "debugger.scm")
|
| ︙ | | |
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
|
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
|
-
+
|
(if (runs:lownoise "waiting on tasks" 60)(debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ..."))
(configf:lookup-number *configdat* "setup" "inter-test-delay" default: 0.1) ;; was 2
);; obviously haven't had any work to do for a while
(else 0)))
(let* ((num-running (rmt:get-count-tests-running run-id))
(num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup))
(job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup)))
(job-group-limit (let ((jobg-count (configf:lookup *configdat* "jobgroups" jobgroup)))
(if (string? jobg-count)
(string->number jobg-count)
jobg-count))))
(if (> (+ num-running num-running-in-jobgroup) 0)
(runs:inc-can-run-more-tests-count runsdat)) ;; (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1)))
(if (not (eq? *last-num-running-tests* num-running))
(begin
|
| ︙ | | |
529
530
531
532
533
534
535
536
537
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
|
529
530
531
532
533
534
535
536
537
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
|
-
+
-
+
|
(let loop ((hed (car test-names)) ;; NOTE: This is the main loop that iterates over the test-names
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
(debug:print-info 4 *default-log-port* "\n\ntestpatt elaboration loop => hed="hed " tal="tal" test-patts="test-patts" test-names="test-names)
(change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening.
(setenv "MT_TEST_NAME" hed) ;;
(let*-values (((waitons waitors config) (tests:get-waitons hed all-tests-registry))
((hed-mode)
(let ((m (config-lookup config "requirements" "mode")))
(let ((m (configf:lookup config "requirements" "mode")))
(if m (map string->symbol (string-split m)) '(normal))))
((hed-itemized-waiton) ;; are items in hed waiting on items of waiton?
(not (null? (lset-intersection eq? hed-mode '(itemmatch itemwait)))))
)
(debug:print-info 8 *default-log-port* "waitons: " waitons)
;; check for hed in waitons => this would be circular, remove it and issue an
;; error
(if (or (member hed waitons)
(member hed waitors))
(begin
(debug:print-error 0 *default-log-port* "test " hed " has listed itself as a waiton or waitor, please correct this!")
(set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))
(set! waitors (filter (lambda (x)(not (equal? x hed))) waitors))))
;; (items (items:get-items-from-config config)))
(if (not (hash-table-ref/default test-records hed #f)) ;; waiton-tconfig below will be #f until that test is visted here at least once
(hash-table-set! test-records ;; BB: we are doing a manual make-tests:testqueue
hed (vector hed ;; 0 ;; testname
config ;; 1
waitons ;; 2
(config-lookup config "requirements" "priority") ;; priority 3
(configf:lookup config "requirements" "priority") ;; priority 3
(tests:get-items config) ;; 4 ;; expand the [items] and or [itemstable] into explict items
#f ;; itemsdat 5
#f ;; spare - used for item-path
waitors ;;
)))
;; update waitors-upon here
(for-each
|
| ︙ | | |
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
|
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
|
-
+
|
(let* ((run-info (rmt:get-run-info run-id))
(tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path"))
(sorted-test-names (tests:sort-by-priority-and-waiton test-records))
(test-registry (make-hash-table))
(registry-mutex (make-mutex))
(num-retries 0)
(max-retries (config-lookup *configdat* "setup" "maxretries"))
(max-retries (configf:lookup *configdat* "setup" "maxretries"))
(max-concurrent-jobs (configf:lookup-number *configdat* "setup" "max_concurrent_jobs" default: 50))
(reglen (if (number? reglen-in) reglen-in 1))
(last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle
(last-time-some-running (current-seconds))
;; (tdbdat (tasks:open-db))
(runsdat (make-runs:dat
;; hed: hed
|
| ︙ | | |
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
|
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
|
-
-
+
+
|
;; (rmt:find-and-mark-incomplete-all-runs)
))
;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns)
(let* ((test-record (hash-table-ref test-records hed))
(test-name (tests:testqueue-get-testname test-record))
(tconfig (tests:testqueue-get-testconfig test-record))
(jobgroup (config-lookup tconfig "test_meta" "jobgroup"))
(testmode (let ((m (config-lookup tconfig "requirements" "mode")))
(jobgroup (configf:lookup tconfig "test_meta" "jobgroup"))
(testmode (let ((m (configf:lookup tconfig "requirements" "mode")))
(if m (map string->symbol (string-split m)) '(normal))))
(itemmaps (tests:get-itemmaps tconfig)) ;; (configf:lookup tconfig "requirements" "itemmap"))
(waitons (tests:testqueue-get-waitons test-record))
(priority (tests:testqueue-get-priority test-record))
(itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f
(items (tests:testqueue-get-items test-record))
(item-path (item-list->path itemdat))
|
| ︙ | | |
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
|
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
|
-
+
|
(exit 1)))
(set! keys (keys:config-get-fields *configdat*))
;; have enough to process -target or -reqtarg here
(if (args:get-arg "-reqtarg")
(let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL
(runconfig (read-config runconfigf #f #t environ-patt: #f)))
(runconfig (configf:read-config runconfigf #f #t environ-patt: #f)))
(if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
(keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash)
(begin
(debug:print-error 0 *default-log-port* "[" (args:get-arg "-reqtarg") "] not found in " runconfigf)
;; (if db (sqlite3:finalize! db))
(exit 1)
|
| ︙ | | |
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
|
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
|
-
+
|
(begin
(set! currrecord (make-vector 11 #f))
(rmt:testmeta-add-record test-name)))
(for-each
(lambda (key)
(let* ((idx (cadr key))
(fld (car key))
(val (config-lookup test-conf "test_meta" fld)))
(val (configf:lookup test-conf "test_meta" fld)))
;; (debug:print 5 *default-log-port* "idx: " idx " fld: " fld " val: " val)
(if (and val (not (equal? (vector-ref currrecord idx) val)))
(begin
(print "Updating " test-name " " fld " to " val)
(rmt:testmeta-update-field test-name fld val)))))
'(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10)))))
|
| ︙ | | |
Modified server.scm
from [8c943654ab]
to [db2f0d05e0].
| ︙ | | |
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
|
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
|
-
+
|
(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 launch))
;; (declare (uses daemon))
(use (prefix mtconfigf configf:))
(include "common_records.scm")
(include "db_records.scm")
(define (server:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
|
| ︙ | | |
Modified sharedat.scm
from [bb858ca5c8]
to [8fd0087a99].
| ︙ | | |
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
-
+
|
;; (use srfi-69)
;; (use regex-case)
;; (use posix)
;; (use json)
;; (use csv)
(use srfi-18)
(use format)
(use (prefix mtconfigf configf:))
(require-library ini-file)
(import (prefix ini-file ini:))
(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
;; (import (prefix sqlite3 sqlite3:))
;;
(declare (uses configf))
|
| ︙ | | |
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
|
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
|
-
+
|
(define (spublish:load-config exe-dir exe-name)
(let* ((fname (conc exe-dir "/." exe-name ".config")))
(ini:property-separator-patt " * *")
(ini:property-separator #\space)
(if (file-exists? fname)
;; (ini:read-ini fname)
(read-config fname #f #t)
(configf:read-config fname #f #t)
(make-hash-table))))
(define (spublish:process-action configdat action . args)
(let* ((target-dir (configf:lookup configdat "settings" "target-dir"))
(user (current-user-name))
(allowed-users (string-split
(or (configf:lookup configdat "settings" "allowed-users")
|
| ︙ | | |
Modified spublish.scm
from [f88672550b]
to [25c7e98c82].
| ︙ | | |
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
-
+
|
(use defstruct)
(use scsh-process)
(use refdb)
(use srfi-18)
(use srfi-19)
(use format)
(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
(use (prefix mtconfigf configf:))
;(declare (uses configf))
;; (declare (uses tree))
(declare (uses margs))
(declare (uses megatest-version))
;; (declare (uses tbd))
|
| ︙ | | |
Modified sretrieve.scm
from [d2b597ab3b]
to [4bbe92def9].
| ︙ | | |
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
-
+
|
(use srfi-19)
(use refdb)
(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
;(declare (uses common))
;(declare (uses configf))
(declare (uses margs))
(declare (uses megatest-version))
(use (prefix mtconfigf configf:))
(include "megatest-fossil-hash.scm")
;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
(include "sauth-paths.scm")
(include "sauth-common.scm")
(define (toplevel-command . args) #f)
|
| ︙ | | |
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
|
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
|
-
+
|
(let* ((usr (current-user-name))
(value (get-restrictions base-path usr)))
value))
(define (sretrieve:load-shell-config fname)
(if (file-exists? fname)
(read-config fname #f #f)
(configf:read-config fname #f #f)
))
(define (is_directory target-path)
(let* ((retval #f))
(sretrieve:do-as-calling-user
(lambda ()
|
| ︙ | | |
Modified subrun.scm
from [bb7061fde4]
to [0d64e4fc19].
| ︙ | | |
21
22
23
24
25
26
27
28
29
30
31
32
33
34
|
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
+
|
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18)
posix-extras directory-utils pathname-expand typed-records format
call-with-environment-variables)
(declare (unit subrun))
;;(declare (uses runs))
(declare (uses db))
(declare (uses common))
(use (prefix mtconfigf configf:))
;;(declare (uses items))
;;(declare (uses runconfig))
;;(declare (uses tests))
;;(declare (uses server))
(declare (uses mt))
;;(declare (uses archive))
;; (declare (uses filedb))
|
| ︙ | | |
Modified tasks.scm
from [358b0b74f6]
to [4790f80cd2].
| ︙ | | |
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
-
+
|
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format)
(import (prefix sqlite3 sqlite3:))
(use (prefix mtconfigf configf:))
(declare (unit tasks))
(declare (uses db))
(declare (uses rmt))
(declare (uses common))
(declare (uses pgdb))
;; (import pgdb) ;; pgdb is a module
|
| ︙ | | |
Modified tests.scm
from [b8a74e9d3b]
to [542b3de7c7].
| ︙ | | |
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
-
+
|
;;======================================================================
;; Tests
;;======================================================================
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(require-library stml)
(use (prefix mtconfigf configf:))
(declare (unit tests))
(declare (uses lock-queue))
(declare (uses db))
(declare (uses tdb))
(declare (uses common))
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
|
| ︙ | | |
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
|
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
|
-
+
-
+
|
;; returns waitons waitors tconfigdat
;;
(define (tests:get-waitons test-name all-tests-registry)
(let* ((config (tests:get-testconfig test-name #f all-tests-registry 'return-procs))) ;; assuming no problems with immediate evaluation, this could be simplified ('return-procs -> #t)
(let ((instr (if config
(config-lookup config "requirements" "waiton")
(configf:lookup config "requirements" "waiton")
(begin ;; No config means this is a non-existant test
(debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"")
(exit 1))))
(instr2 (if config
(config-lookup config "requirements" "waitor")
(configf:lookup config "requirements" "waitor")
"")))
(debug:print-info 8 *default-log-port* "waitons string is " instr ", waitors string is " instr2)
(let ((newwaitons
(string-split (cond
((procedure? instr) ;; here
(let ((res (instr)))
(debug:print-info 8 *default-log-port* "waiton procedure results in string " res " for test " test-name)
|
| ︙ | | |
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
|
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
|
-
+
|
(let* ((treg (or test-registry
(tests:get-all)))
(test-path (or (hash-table-ref/default treg test-name #f)
(conc *toppath* "/tests/" test-name)))
(test-configf (conc test-path "/testconfig"))
(testexists (and (common:file-exists? test-configf)(file-read-access? test-configf)))
(tcfg (if testexists
(read-config test-configf #f system-allowed
(configf:read-config test-configf #f system-allowed
environ-patt: (if system-allowed
"pre-launch-env-vars"
#f))
#f)))
(if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
(if tcfg (hash-table-set! *testconfigs* test-full-name tcfg))
(if (and testexists
|
| ︙ | | |
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
|
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
|
-
-
+
+
|
(lambda (a b)
(let* ((a-record (hash-table-ref test-records a))
(b-record (hash-table-ref test-records b))
(a-waitons (or (tests:testqueue-get-waitons a-record) '()))
(b-waitons (or (tests:testqueue-get-waitons b-record) '()))
(a-config (tests:testqueue-get-testconfig a-record))
(b-config (tests:testqueue-get-testconfig b-record))
(a-raw-pri (config-lookup a-config "requirements" "priority"))
(b-raw-pri (config-lookup b-config "requirements" "priority"))
(a-raw-pri (configf:lookup a-config "requirements" "priority"))
(b-raw-pri (configf:lookup b-config "requirements" "priority"))
(a-priority (mungepriority a-raw-pri))
(b-priority (mungepriority b-raw-pri)))
(tests:testqueue-set-priority! a-record a-priority)
(tests:testqueue-set-priority! b-record b-priority)
;; (debug:print 0 *default-log-port* "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons)
(cond
;; is
|
| ︙ | | |
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
|
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
|
-
+
|
(if (not (null? test-names))
(let loop ((hed (car test-names))
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
(debug:print-info 4 *default-log-port* "hed=" hed " at top of loop")
;; don't know item-path at this time, let the testconfig get the top level testconfig
(let* ((config (tests:get-testconfig hed #f all-tests-registry 'return-procs))
(waitons (let ((instr (if config
(config-lookup config "requirements" "waiton")
(configf:lookup config "requirements" "waiton")
(begin ;; No config means this is a non-existant test
(debug:print-error 0 *default-log-port* "non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.")
""))))
(debug:print-info 8 *default-log-port* "waitons string is " instr)
(string-split (cond
((procedure? instr)
(let ((res (instr)))
|
| ︙ | | |
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
|
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
|
-
+
|
;; (items (items:get-items-from-config config)))
(if (not (hash-table-ref/default test-records hed #f))
(hash-table-set! test-records
hed (vector hed ;; 0
config ;; 1
waitons ;; 2
(config-lookup config "requirements" "priority") ;; priority 3
(configf:lookup config "requirements" "priority") ;; priority 3
(let ((items (hash-table-ref/default config "items" #f)) ;; items 4
(itemstable (hash-table-ref/default config "itemstable" #f)))
;; if either items or items table is a proc return it so test running
;; process can know to call items:get-items-from-config
;; if either is a list and none is a proc go ahead and call get-items
;; otherwise return #f - this is not an iterated test
(cond
|
| ︙ | | |
Modified utils/mk_wrapper
from [a247eee08b]
to [19d546f47d].
| ︙ | | |
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
-
+
|
cmd=$2
target=$3
cfgfile="$prefix/bin/.$(lsb_release -sr)/cfg.sh"
if [ "$LD_LIBRARY_PATH" != "" ];then
echo "INFO: Using LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >&2
( cat << __EOF
if [ "\$LD_LIBRARY_PATH" != "" ];then
if [[ -z \$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
|
| ︙ | | |