Megatest: Changes On Branch 831718d65cba6875

Changes In Branch v2.01-local-mtfiles Through [831718d65c] Excluding Merge-Ins

This is equivalent to a diff from c6761db385 to 831718d65c

2019-01-17
15:43		wip check-in: a42ae2762b user: bjbarcla tags: v2.01-local-mtfiles, v2.01-try-1
2019-01-07
17:21		updated repository-path to work for any chicken number check-in: 831718d65c user: bjbarcla tags: v2.01-local-mtfiles, v2.01-try-1
11:51		added modules to launch.scm and portlogger.scm and tasks.scm; eliminating various stack dumps check-in: 650916aff7 user: bjbarcla tags: v2.01-local-mtfiles, v2.01-try-1
2018-11-29
15:00		partial conversion to local files for mt* check-in: dbc9e048de user: mrwellan tags: v2.01-local-mtfiles, v2.01-try-1
2018-11-28
14:44		Corrected couple mis-ported items for the mt* stuff Leaf check-in: c6761db385 user: mrwellan tags: v2.01-try-1
2018-11-27
15:43		Merged changes from trunk check-in: 851bcc0c6b user: mrwellan tags: v2.01-try-1

Modified .fossil-settings/ignore-glob from [9a873b8335] to [ca102417c5].

Modified Makefile from [2a43e569cb] to [ac31ce093c].

Modified TODO from [19e430807b] to [ca19aa8019].

Modified archive.scm from [618f9a591e] to [263176e769].

Modified cgisetup/models/pgdb.scm from [015f5f388e] to [644c3cf297].

Modified common.scm from [8b5ebebcbe] to [b9bcfdcae7].

Modified common_records.scm from [72d272b34e] to [8bc4f3e8d1].

Modified dashboard-context-menu.scm from [0a1e7c69d9] to [0834416172].

Modified dashboard-tests.scm from [2af1eb577e] to [243b9935bb].

Modified dashboard.scm from [a26576c28a] to [7302194f8a].

Modified datashare.scm from [2c1663032f] to [0e35c400e8].

Modified db.scm from [b49a2db6be] to [5083d17e82].

Modified dcommon.scm from [2d492dcb7c] to [e8febd6b5b].

Modified ezsteps.scm from [80e8d0742f] to [3c83214f25].

Modified ftail.scm from [96a7ff77a3] to [721728b98f].

Modified http-transport.scm from [da311848d8] to [61e3efdebc].

Modified items.scm from [2265706948] to [f57d8260ff].

Modified keys.scm from [9fa2c0cfa5] to [49ff1d279c].

Modified launch.scm from [7a44cc90cf] to [fff95c3307].

Modified megatest.scm from [cecad5eaf2] to [32872ea46a].

Added modules.scm version [4ab26bda3c].

Modified mt.scm from [3cc1b8b1ff] to [dfecc22fb1].

Modified mtut.scm from [50be2de849] to [e6768aeeb6].

Modified newdashboard.scm from [3cc17ecae4] to [870867b690].

Modified portlogger.scm from [8b8ee119e5] to [1e31f0db2f].

Modified rpc-transport.scm from [dd887f94ec] to [ff050cf9d6].

Modified runconfig.scm from [66b9c38588] to [f10586d4dd].

Modified runs.scm from [18e897116f] to [87f0900907].

Modified sauthorize.scm from [c2546fdee5] to [0305bbd2de].

Modified server.scm from [8c943654ab] to [5fa0f58af3].

Modified sharedat.scm from [bb858ca5c8] to [01f126d441].

Modified spublish.scm from [f88672550b] to [c862e884d7].

Modified sretrieve.scm from [d2b597ab3b] to [32d4848be0].

Modified subrun.scm from [bb7061fde4] to [a2dfab0c27].

Modified tasks.scm from [358b0b74f6] to [3ce858550a].

Modified tcmt.scm from [679021e6ef] to [17cd15a2bf].

Modified tests.scm from [b8a74e9d3b] to [e1607a72c2].

Modified tree.scm from [ffabd357b5] to [50e9a6d574].

Modified utils/mk_wrapper from [a247eee08b] to [19d546f47d].


1 2 3 4 5 6 7	1 2 3 4 5 6 7 8	+	tmpinstall tests/fullrun/logs/* tests/fullrun/lt tests/fullrun/megatest.db altdb.scm utils/build/* ~ .o
︙
44 45 46 47 48 49 50	45 46 47 48 49 50 51 52 53 54	+ + +	tests/fdktestqa/simplelinks/* tests/fdktestqa/testqa/megatest.db tests/fdktestqa/testqa/monitor.db megatest-fossil-hash.scm tests/release/runs/* tests/release/links/* tests/release/megatest.db tcmt mtut *.import.scm

︙
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	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	- - + + - + + + - + + + - + - - + + + + + + + + + + + + + + + - + - + - - + + + - - - + + + + + + + + + + + + + + + + + - - + +	# # 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 \~~ db.scm keys.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) CHICKEN_NUMBER = $(shell csi -e '(print (car (reverse (string-split (repository-path) "/"))))') ~~~~mofiles/~~%.o : %.scm~~ %.o : %.scm ../adat.scm $(MTEGGS) ~~~~mkdir -p mofiles~~ csc $(CSCOPTS) -J -c $< -o ~~mofiles/~~$.o~~ csc $(CSCOPTS) -J -c $< -o $.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}') MT_EGGS_BASE=$(PREFIX)/eggs MT_EGGS_DIR=$(MT_EGGS_BASE)/lib/chicken/$(CHICKEN_NUMBER) MTEGGS=$(MT_EGGS_DIR)/mtconfigf.so $(MT_EGGS_DIR)/mtdebug.so $(MT_EGGS_DIR)/mtargs.so CHICKEN_REPOSITORY=$(MT_EGGS_DIR) export CHICKEN_REPOSITORY #CSCOPTS=-Wl,-rpath,$(MT_EGGS_DIR) # prefix commands with $(withenv) following as a means to collect env vars for compilation... withenv=CHICKEN_REPOSITORY=$(MT_EGGS_DIR) ifeq ($(MTESTHASH),) $(error MTESTHASH is broken!) endif CKREPOSITORY=$(shell chicken-install -repository) 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 if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") PNGFILES = $(shell cd docs/manual;ls *png) $(MOFILES): $(MTEGGS) $(MT_EGGS_DIR)/types.db #all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard ~~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) $(MOFILES) megatest-fossil-hash.scm mtut.scm csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut eggs: $(MTEGGS) ~~mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm~~ ~~csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut~~ # Needed only for adat.scm OPENSRC_DIR=../opensrc MTUTILS_DIR=$(OPENSRC_DIR)/mtutils ../adat.scm : $(MTUTILS_DIR)/adat.scm ln -sf $(PWD)/$< $@ # # stuff for handling external files from opensrc package # mtcommon.scm : $(MTUTILS_DIR)/mtcommon/mtcommon.scm # ln -sf $< $@ # # mtdb.scm : $(MTUTILS_DIR)/mtdb/mtdb.scm # ln -sf $< $@ # # mtconfigf.scm : $(MTUTILS_DIR)/mtconfigf/mtconfigf.scm # ln -sf $< $@ # TCMTOBJS = \ api.o \ archive.o \ cgisetup/models/pgdb.o \ client.o \ common.o \ db.o \ env.o \ http-transport.o \ items.o \ keys.o \ launch.o \ lock-queue.o \ ~~margs.o \~~ mt.o \ megatest-version.o \ ods.o \ portlogger.o \ process.o \ rmt.o \ 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 164 165 166 ~~167~~ 168 ~~169~~ 170 171 172 173 174 175 176	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	+ + + + - - + + + + + + + + + - - - + + + + + + + + + + + + + + + - - + + - + + - +	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 # setup the eggs dir in $PREFIX # $(MT_EGGS_DIR) : mkdir -p $(MT_EGGS_DIR) ~~#multi-dboard : multi-dboard.scm $(OFILES) $(GOFILES)~~ ~~# csc $(CSCOPTS) $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard~~ $(MT_EGGS_DIR)/types.db : $(MT_EGGS_DIR) cp -rsf $(CKREPOSITORY)/ $(MT_EGGS_BASE)/lib/chicken/ # chicken-install -init $(MT_EGGS_DIR) csi: csi $(MT_EGGS_DIR)/mtargs.so : $(MT_EGGS_DIR)/types.db $(MTUTILS_DIR)/mtargs/mtargs.scm cd $(MTUTILS_DIR)/mtargs && chicken-install -prefix $(MT_EGGS_BASE) ~~# ~~# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm~~ ~~# csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl~~~~ $(MT_EGGS_DIR)/mtdebug.so : $(MT_EGGS_DIR)/types.db $(MTUTILS_DIR)/mtdebug/mtdebug.scm $(MT_EGGS_DIR)/mtargs.so cd $(MTUTILS_DIR)/mtdebug && chicken-install -prefix $(MT_EGGS_BASE) $(MT_EGGS_DIR)/mtconfigf.so : $(MT_EGGS_DIR)/types.db $(MTUTILS_DIR)/mtconfigf/mtconfigf.scm $(MT_EGGS_DIR)/mtdebug.so cd $(MTUTILS_DIR)/mtconfigf && chicken-install -prefix $(MT_EGGS_BASE) # # Special dependencies for the includes # # anything that depends on the special MOFILES needs to be listed on the left here launch.o : $(MOFILES) # mtconfigf.o : $(MTUTILS_DIR)/mtconfigf/mtconfigf.scm tests.o db.o launch.o runs.o dashboard-tests.o dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o \ archive.o megatest.o : db_records.scm tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.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 megatest.o : megatest-fossil-hash.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 common_records.scm : altdb.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) $(MT_EGGS_DIR)/types.db common_records.scm : altdb.scm modules.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 echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new 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~~ $(OFILES) $(GOFILES) : common_records.scm modules.scm # TODO: make modules.scm changes trigger rebuild. modules.scm in following recipe does not work. ~~%.o : %.scm~~ %.o : %.scm modules.scm csc $(CSCOPTS) -c $< $(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper @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
︙
264 265 266 267 268 269 270 271 272 273 274 275 276 277	320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335	+ +	$(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	353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371	- + + + + +	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 \ rm -rf $(PREFIX)/* #====================================================================== # Make the records files #====================================================================== # vg_records.scm : records.sh # ./records.sh
︙
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	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	- + - + - - + + - - + + - - + +	deploytarg/dboard : $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg mv deploytarg/deploytarg deploytarg/dboard # DATASHAREO=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)~~ datashare-testing/sd : datashare.scm $(OFILES) modules.scm csc $(CSCOPTS) datashare.scm $(OFILES) -o datashare-testing/sd ~~datashare-testing/sdat: sharedat.scm $(OFILES)~~ datashare-testing/sdat: sharedat.scm $(OFILES) modules.scm csc $(CSCOPTS) sharedat.scm $(OFILES) -o datashare-testing/sdat 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 &) ~~datashare-testing/spublish : spublish.scm $(OFILES) csc $(CSCOPTS) spublish.scm megatest-version.o ~~margs.o~~ process.o common.o -o datashare-testing/spublish~~ datashare-testing/spublish : spublish.scm $(OFILES) modules.scm csc $(CSCOPTS) spublish.scm megatest-version.o process.o common.o -o datashare-testing/spublish ~~datashare-testing/sretrieve : sretrieve.scm $(OFILES) csc $(CSCOPTS) sretrieve.scm megatest-version.o ~~margs.o~~ process.o common.o -o datashare-testing/sretrieve~~ datashare-testing/sretrieve : sretrieve.scm $(OFILES) modules.scm csc $(CSCOPTS) sretrieve.scm megatest-version.o process.o common.o -o datashare-testing/sretrieve ~~datashare-testing/sauthorize : sauthorize.scm $(OFILES) csc $(CSCOPTS) sauthorize.scm megatest-version.o ~~margs.o~~ process.o common.o -o datashare-testing/sauthorize~~ datashare-testing/sauthorize : sauthorize.scm $(OFILES) modules.scm csc $(CSCOPTS) sauthorize.scm megatest-version.o process.o common.o -o datashare-testing/sauthorize sauth-init: mkdir -p datashare-testing rm datashare-testing/sauthorize rm datashare-testing/sretrieve rm datashare-testing/spublish
︙
394 395 396 397 398 399 400 ~~401 402~~ 403 404 405 406 407 408 409	456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471	- - + +	if csi -ne '(use mysql-client)';then \ echo "(use mysql-client)(hash-table-set! available-db 'mysql #t)" >> altdb.scm; \ fi if csi -ne '(use postgresql)';then \ echo "(use postgresql)(hash-table-set! available-db 'postgresql #t)" >> altdb.scm;\ fi portlogger-example : portlogger-example.scm api.o archive.o client.o common.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o ~~margs.o~~ megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o ~~margs.o~~ megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o portlogger-example : portlogger-example.scm api.o archive.o client.o common.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o # create a pdf dot graphviz diagram from notations in rmt.scm rmt.pdf : rmt.scm grep ';;DOT' rmt.scm \| sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf buildmanual: cd docs/manual && make
︙

︙
22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37	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	+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + + + + +	format dot-locking csv-xml z3 ;; sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack matchable regex posix (srfi 18) extras ;; tcp (prefix nanomsg nmsg:) (prefix sqlite3 sqlite3:) pkts (prefix dbi dbi:) ) (declare (uses process)) (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-number (car (reverse (string-split (repository-path) "/")))) (libpath (conc common:this-exe-dir "/../../eggs/lib/chicken/" libpath-number))) (if (and (not (get-environment-variable "CHICKEN_REPOSITORY")) (directory-exists? libpath)) (repository-path libpath))) ~~(declare (u~~nit~~ co~~mmon~~))~~ ;;(declare (uses mtconfigf)) ;; (use (prefix mtconfigf configf:)) ;;(configf:add-eval-string "(use common)") (include "common_records.scm") ;; (require-library margs) ;; (include "margs.scm")
︙
123 124 125 126 127 128 129 ~~130~~ 131 132 133 134 135 136 137	168 169 170 171 172 173 174 175 176 177 178 179 180 181 182	- +	(define already-seen-runconfig-info #f) (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 alt-log-file #f) ;; used by -log (define common:denoise (make-hash-table)) ;; for low noise printing ~~(define default-log-port (current-error-port))~~ ;;(define default-log-port (current-error-port)) moved to modules.scm (define time-zero (current-seconds)) ;; for the watchdog (define default-area-tag "local") ;; DATABASE (define dbstruct-db #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this. ;; db stats (define db-stats (make-hash-table)) ;; hash of vectors < count duration-total >
︙
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	235 236 237 238 239 240 241 242 243 244 245 246 247 248	- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -	(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))~~ (defstruct remote (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag )
︙
258 259 260 261 262 263 264 ~~265 266 267 268~~ 269 270 271 272 273 274 275	271 272 273 274 275 276 277 278 279 280 281 282 283 284	- - - -	(define testconfigs (make-hash-table)) ;; test-name => testconfig (define runconfigs (make-hash-table)) ;; target => runconfig ;; This is a cache of pre-reqs met, don't re-calc in cases where called with same params less than ;; five seconds ago (define pre-reqs-met-cache (make-hash-table)) ~~;; cache of verbosity given string~~ ;; ~~(define verbosity-cache (make-hash-table))~~ (define (common:clear-caches) (set! target (make-hash-table)) (set! keys (make-hash-table)) (set! keyvals (make-hash-table)) (set! toptest-paths (make-hash-table)) (set! test-paths (make-hash-table)) (set! test-ids (make-hash-table))
︙
901 902 903 904 905 906 907 ~~908~~ 909 910 911 912 913 914 915	910 911 912 913 914 915 916 917 918 919 920 921 922 923 924	- +	(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	1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016	- +	;;====================================================================== ;; (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	2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699	- + - +	;; 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:
︙

︙
17 18 19 20 21 22 23 24 25 26 27 28 29 30	17 18 19 20 21 22 23 24 25 26 27 28 29 30 31	+	;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;;====================================================================== ;; (use trace) (include "altdb.scm") (include "modules.scm") ;; Some of these routines use: ;; ;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html ;; ;; Syntax for defining macros in a simple style similar to function definiton, ;; when there is a single pattern for the argument list and there are no keywords.
︙
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	75 76 77 78 79 80 81 82 83 84 85 86 87 88	- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -	;; (define-inline (with-mutex mtx accessor record . val) (mutex-lock! mtx) (let ((res (apply accessor record val))) (mutex-unlock! mtx) res)) ~~;; this was cached based on results from profiling but it turned out the profiling~~ ~~;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching~~ ~~;; in for now but can probably take it out later.~~ ;; ~~(define (debug:calc-verbosity vstr)~~ ~~(or (hash-table-ref/default verbosity-cache vstr #f)~~ ~~(let ((res (cond~~ ~~((number? vstr) vstr)~~ ~~((not (string? vstr)) 1)~~ ~~;; ((string-match "^\\s$" vstr) 1)~~ ~~(vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))~~ ~~(cond~~ ~~((> (length debugvals) 1) debugvals)~~ ~~((> (length debugvals) 0)(car debugvals))~~ ~~(else 1))))~~ ~~((args:get-arg "-v") 2)~~ ~~((args:get-arg "-q") 0)~~ ~~(else 1))))~~ ~~(hash-table-set! verbosity-cache* vstr res)~~ ~~res)))~~ ~~;; check verbosity, #t is ok~~ ~~(define (debug:check-verbosity verbosity vstr)~~ ~~(if (not (or (number? verbosity)~~ ~~(list? verbosity)))~~ ~~(begin~~ ~~(print "ERROR: Invalid debug value \"" vstr "\"")~~ ~~#f)~~ ~~#t))~~ ~~(define (debug:debug-mode n)~~ ~~(cond~~ ~~((and (number? verbosity) ;; number number~~ ~~(number? n))~~ ~~(<= n verbosity))~~ ~~((and (list? verbosity) ;; list number~~ ~~(number? n))~~ ~~(member n verbosity))~~ ~~((and (list? verbosity) ;; list list~~ ~~(list? n))~~ ~~(not (null? (lset-intersection! eq? verbosity n))))~~ ~~((and (number? verbosity)~~ ~~(list? n))~~ ~~(member verbosity n))))~~ ~~(define (debug:setup)~~ ~~(let ((debugstr (or (args:get-arg "-debug")~~ ~~(getenv "MT_DEBUG_MODE"))))~~ ~~(set! verbosity (debug:calc-verbosity debugstr))~~ ~~(debug:check-verbosity verbosity debugstr)~~ ~~;; if we were handed a bad verbosity rule then we will override it with 1 and continue~~ ~~(if (not verbosity)(set! verbosity 1))~~ ~~(if (or (args:get-arg "-debug")~~ ~~(not (getenv "MT_DEBUG_MODE")))~~ ~~(setenv "MT_DEBUG_MODE" (if (list? verbosity)~~ ~~(string-intersperse (map conc verbosity) ",")~~ ~~(conc verbosity))))))~~ ~~(define (debug:print n e . params)~~ ~~(if (debug:debug-mode n)~~ ~~(with-output-to-port (or e (current-error-port))~~ ~~(lambda ()~~ (if logging ~~(db:log-event (apply conc params))~~ ~~(apply print params)~~ ~~)))))~~ ;; Brandon's debug printer shortcut (indulge me :) (define BB-process-starttime (current-milliseconds)) (define (BB> . in-args) (let* ((stack (get-call-chain)) (location "??")) (for-each
︙
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	145 146 147 148 149 150 151 152 153 154 155 156 157 158 159	- - - - - - - - - - - - - - - - - - - - - - - - - - -	[(_ x) ;; (with-output-to-port (current-error-port) (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x)))) ;; ) ] [(_ x y ...) (begin (inspect x) (inspect y ...))])) ~~(define (debug:print-error n e . params)~~ ~~;; normal print~~ ~~(if (debug:debug-mode n)~~ ~~(with-output-to-port (if (port? e) e (current-error-port))~~ ~~(lambda ()~~ (if logging ~~(db:log-event (apply conc params))~~ ~~;; (apply print "pid:" (current-process-id) " " params)~~ ~~(apply print "ERROR: " params)~~ ~~))))~~ ~~;; pass important messages to stderr~~ ~~(if (and (eq? n 0)(not (eq? e (current-error-port))))~~ ~~(with-output-to-port (current-error-port)~~ ~~(lambda ()~~ ~~(apply print "ERROR: " params)~~ ~~))))~~ ~~(define (debug:print-info n e . params)~~ ~~(if (debug:debug-mode n)~~ ~~(with-output-to-port (if (port? e) e (current-error-port))~~ ~~(lambda ()~~ (if logging ~~(let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))~~ ~~(db:log-event res))~~ ~~;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)~~ ~~(apply print "INFO: (" n ") " params) ;; res)~~ ~~)))))~~ ;; if a value is printable (i.e. string or number) return the value ;; else return an empty string (define-inline (printable val) (if (or (number? val)(string? val)) val ""))

︙
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	- + - - + - + + +	;; ;;====================================================================== (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 common)) ~~(declare (uses margs))~~ (declare (uses keys)) (declare (uses items)) (declare (uses db)) ~~;; (declare (uses configf))~~ ;;(declare (uses mtconfigf)) (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	1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937	- +	;;====================================================================== ;; 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
︙

︙
28 29 30 31 32 33 34 35 36 37 38 39 40 ~~41 42~~ 43 44 45 46 47 48 49 50 51	28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51	- + - - + + - +	(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))~~ (include "modules.scm") ;;(declare (uses configf)) (declare (uses tree)) ~~(declare (uses margs))~~ ;;(declare (uses margs)) ;; (declare (uses dcommon)) ;; (declare (uses launch)) ;; (declare (uses gutils)) ;; (declare (uses db)) ;; (declare (uses synchash)) ;; (declare (uses server)) ;; (declare (uses megatest-version))
︙
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
︙

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

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

︙
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 656 657 658 659 ~~660~~ 661 662 663 664 665 666 667	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	- + - +	(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) (let ((var (car varval)) (val (cadr varval))) (if (and (string? var)(string? val)) (begin ~~(safe-setenv var (config:eval-string-in-environment val))) ;; val)~~ (safe-setenv var (configf:eval-string-in-environment val))) ;; val) (debug:print-error 0 default-log-port "bad variable spec, " var "=" val)))) (configf:get-section rconfig section))) (list "default" target))) ;;(bb-check-path msg: "launch:execute post block 1") ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0))
︙
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)
︙

︙
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	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	- + +	(require-library mutils) ;; (use zmq) (declare (uses common)) (declare (uses megatest-version)) ~~(declare (uses margs))~~ (declare (uses runs)) (declare (uses launch)) (declare (uses server)) (declare (uses client)) (declare (uses tests)) (declare (uses genexample)) ;; (declare (uses daemon)) (declare (uses db)) ;; (declare (uses dcommon)) (declare (uses tdb)) (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)) (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")
︙
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	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	- + - + - + +	(printf "Sending signal/term to ~A\n" pid) (process-signal pid signal/term)))))) (process:children #f)) (original-exit exit-code))))) ;; for some switches always print the command to stderr ;; ~~(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status")~~ (if (args:any-defined? "-run" "-runall" "-remove-runs" "-set-state-status") (debug:print 0 default-log-port (string-intersperse (argv) " "))) ;; some switches imply homehost. Exit here if not on homehost ;; (let ((homehost-required (list "-cleanup-db" "-server"))) ~~(if (apply args:any? homehost-required)~~ (if (apply args:any-defined? homehost-required) (if (not (common:on-homehost?)) (for-each (lambda (switch) (if (args:get-arg switch) (begin (debug:print 0 default-log-port "ERROR: you must be on the homehost to run with " switch ", you can move homehost by removing the .homehost file but this will disrupt any runs in progress.") (exit 1)))) homehost-required)))) ;;====================================================================== ;; Misc setup stuff ;;====================================================================== (debug:setup) ~~(if (args:get-arg "-logging")~~(set! logging #t))~~~~ (if (args:get-arg "-logging") (debug:add-logging-callback db:log-event)) (if (debug:debug-mode 3) ;; we are obviously debugging (set! open-run-close open-run-close-no-exception-handling)) (if (args:get-arg "-itempatt") (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) (debug:print 0 default-log-port "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
︙
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"))))
︙











































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	+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +	;;====================================================================== ;; Copyright 2006-2018, Matthew Welland. ;; ;; This file is part of Megatest. ;; ;; Megatest is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; Megatest is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (use (prefix mtargs args:)) (use mtdebug) (use (prefix mtconfigf configf:)) ;; configure mtdebug ;; TODO: move to megatest.scm with other command line arg processing (if (args:get-arg "-v") (debug:set-verbose-mode)) (if (args:get-arg "-q") (debug:set-quiet-mode)) (if (args:get-arg "-debug") (debug:set-verbosity (args:get-arg "-debug"))) (if (args:get-arg "-color") (case (string->symbol (args:get-arg "-color")) ((y Y yes YES t T) (debug:force-color)) ((n N no NO f F) (debug:suppress-color)))) ;; configure mtconfigf (define default-log-port (current-error-port)) (let* ((normal-fn debug:print) (info-fn debug:print-info) (error-fn debug:print-error) (default-port default-log-port)) (configf:set-debug-printers normal-fn info-fn error-fn default-port)) (configf:add-eval-string "(import (prefix mtargs args:)) (import mtdebug) (import (prefix mtconfigf configf:))")

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

︙
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 common)) (declare (uses megatest-version)) ~~(declare (uses margs)) ;; (declare (uses ~~configf~~)) ;; (declare (uses ~~rmt~~))~~ ;;(declare (uses margs)) ;; (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)
︙
470 471 472 473 474 475 476 ~~477~~ 478 479 480 481 482 483 484	473 474 475 476 477 478 479 480 481 482 483 484 485 486 487	- +	(args:get-arg "-envcap") (args:get-arg "-envdelta") (member action '("db" "tsend" "tlisten")) ;; very loose checks on db and tsend/listen (equal? action "show") ;; just keep going if list ))) (debug:print-error 0 default-log-port "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) ~~(if (or (args:any? "-h" "help" "-help" "--help")~~ (if (or (args:any-defined? "-h" "help" "-help" "--help") (member action '("-h" "-help" "--help" "help"))) (begin (print help) (exit 1))) ;;====================================================================== ;; Nanomsg transport
︙

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

︙
26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49	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	- + + - + - +	;; (use srfi-69) ;; (use regex-case) ;; (use posix) ;; (use json) ;; (use csv) (use srfi-18) (use format) (require "modules.scm") ;;;; (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))~~ ;; (declare (uses configf)) ;; (declare (uses tree)) ~~(declare (uses margs))~~ ;; (declare (uses margs)) ;; (declare (uses dcommon)) ;; (declare (uses launch)) ;; (declare (uses gutils)) ;; (declare (uses db)) ;; (declare (uses synchash)) ;; (declare (uses server)) (declare (uses megatest-version))
︙
340 341 342 343 344 345 346 ~~347~~ 348 349 350 351 352 353 354	341 342 343 344 345 346 347 348 349 350 351 352 353 354 355	- +	(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")
︙

︙
21 22 23 24 25 26 27 28 29 ~~30 31~~ 32 33 34 35 36 37 38	21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38	- + - - + +	(use scsh-process) (use srfi-18) (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 margs)) (declare (uses megatest-version)) ;;;; (use (prefix mtconfigf configf:)) (include "modules.scm") (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) (use readline)
︙
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 ()
︙