Megatest

Changes On Branch 15a47376a61ed0a8
Login

Changes In Branch v1.65-adjutant-patched-forward-defunct Through [15a47376a6] Excluding Merge-Ins

This is equivalent to a diff from 92c105d9bc to 15a47376a6

2024-08-15
20:21
Patched forward adjutant code Leaf check-in: 97bcfbf545 user: matt tags: v1.65-adjutant-patched-forward
19:14
Cleaned up some junk from the patch forward. Closed-Leaf check-in: 5ec348be6d user: matt tags: v1.65-adjutant-patched-forward-defunct
18:16
Patched forward adjutant code check-in: 15a47376a6 user: matt tags: v1.65-adjutant-patched-forward-defunct
2022-05-16
20:27
Merged file adds, cleanup from v1.70 to facilitate moving functions to module files Leaf check-in: e9b009e0a2 user: matt tags: v1.65-cleanup-tweak
19:55
Experimentally adding dbfile.scm Closed-Leaf check-in: 4b7f6bdfbc user: matt tags: v1.65-delme
2022-05-15
05:01
Rebased v1.7001-multi-db forward to tip of v1.65, old branch is hidden check-in: 820ac9a873 user: matt tags: v1.70
2022-05-13
13:17
Remove global waiton from itself. Leaf check-in: 92c105d9bc user: mrwellan tags: v1.65
12:16
Fixed few things with the hasty implementation of global waitons. check-in: 0c7e3bc287 user: mrwellan tags: v1.65

Modified Makefile from [dd76a98688] to [e5c890e93c].

26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
           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 = dbmod.scm
# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm	\
#             mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm	\
#             rmtmod.scm apimod.scm

GUISRCF = dashboard-context-menu.scm dashboard-tests.scm		\
          dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm	\







|







26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
           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 = dbmod.scm adjutant.scm mutils.scm mttop.scm
# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm	\
#             mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm	\
#             rmtmod.scm apimod.scm

GUISRCF = dashboard-context-menu.scm dashboard-tests.scm		\
          dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm	\
91
92
93
94
95
96
97
98

99
100
101
102
103
104
105

dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-version.scm megatest-fossil-hash.scm
	csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard

mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm megatest-version.scm
	csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut

# include makefile.inc


TCMTOBJS = \
	api.o \
	archive.o \
	cgisetup/models/pgdb.o \
	client.o \
	common.o \







|
>







91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106

dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-version.scm megatest-fossil-hash.scm
	csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard

mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm megatest-version.scm
	csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut

include makefile.inc
include chicken.makefile

TCMTOBJS = \
	api.o \
	archive.o \
	cgisetup/models/pgdb.o \
	client.o \
	common.o \

Modified NOTES from [7c075bb80d] to [0b75f67e74].

10
11
12
13
14
15
16





17
18
19
20
21
22
23
#     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/>.






=====================================================================
NOTES from looking at branch v1.62-rpc
=====================================================================

*last-db-access* or *db-last-access* ==> which is it to be?
seen in singletest: ERROR: Unrecognised arguments: :first_err This is the first error







>
>
>
>
>







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
#     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/>.

(server:writable-watchdog-bruteforce dbstruct)

(server:writable-watchdog-deltasync dbstruct)


=====================================================================
NOTES from looking at branch v1.62-rpc
=====================================================================

*last-db-access* or *db-last-access* ==> which is it to be?
seen in singletest: ERROR: Unrecognised arguments: :first_err This is the first error

Modified TODO from [da5eae4898] to [dcd0f52bc7].

14
15
16
17
18
19
20







21
22
23
24
25
26
27
# 
#     You should have received a copy of the GNU General Public License
#     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

TODO
====








WW15
. fill newview matrix with data, filter pipeline gui elements
. improve [script], especially indent handling

WW16
. split db into megatest.db (runs etc.) db/<something>.db
. release basic newview implementation







>
>
>
>
>
>
>







14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
# 
#     You should have received a copy of the GNU General Public License
#     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

TODO
====

WW38
. Add test_rundat to no-sync ==> correction, put in <testdir>/.meta/test-run.dat
. Add STATE/STATUS transitions to .meta/test-run.dat or similar
. Swizzle update-test-rundat to operate on no-sync
. Swizzle update-run-duration, -uname-host and cpuload-diskfree to no-sync
. On state/status change update tests table with duration

WW15
. fill newview matrix with data, filter pipeline gui elements
. improve [script], especially indent handling

WW16
. split db into megatest.db (runs etc.) db/<something>.db
. release basic newview implementation

Modified adjutant.scm from [7560fecb1c] to [d6c67b1549].

20
21
22
23
24
25
26
27
28
29
30
31











32
33

(declare (unit adjutant))

(module adjutant *

(import scheme chicken data-structures extras files)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
	md5 message-digest
	regex srfi-1)

(define (adjutant-run)
  (print "Running the adjutant!"))












)







|


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


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

(declare (unit adjutant))

(module adjutant *

(import scheme chicken data-structures extras files)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
	md5 message-digest matchable
	regex srfi-1)

(define (adjutant-run host-type rmt:no-sync-take-job)
  (print "Running the adjutant!")
  (let loop ((wait-count 0))
    (if (< wait-count 10) ;; 6 x 10 seconds = one minute
	(let* ((dat (rmt:no-sync-take-job host-type)))
	  (match dat
	    ((id ht vars exekey cmdline state event-time last-update)
	     (system cmdline)
	     (loop 0))
	    (else
	     (thread-sleep! 10)
	     (loop (+ wait-count 1)))))
	(print "I'm bored. Exiting."))))

)

Modified api.scm from [c2c4883b3a] to [6784eb775b].

157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184


185
186
187
188
189
190
191
    ((not (vector? dat))                    ;; it is an error to not receive a vector
     (vector #f (vector #f "remote must be called with a vector")))
    ((> *api-process-request-count* 20) ;; 20)
     (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.")
     (set! *server-overloaded* #t)
     (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor!
    (else  
     (let* ((cmd-in            (vector-ref dat 0))
            (cmd               (if (symbol? cmd-in)
				   cmd-in
				   (string->symbol cmd-in)))
            (params            (vector-ref dat 1))
            (start-t           (current-milliseconds))
            (readonly-mode     (dbr:dbstruct-read-only dbstruct))
            (readonly-command  (member cmd api:read-only-queries))
            (writecmd-in-readonly-mode (and readonly-mode (not readonly-command)))
            #;(foo               (begin
                                 (common:telemetry-log (conc "api-in:"(->string cmd))
                                                       payload: `((params . ,params)))
                                 
                                 #t))
            (res    
             (if writecmd-in-readonly-mode
                 (conc "attempt to run write command "cmd" on a read-only database")
                 (case cmd
                   ;;===============================================
                   ;; READ/WRITE QUERIES
                   ;;===============================================



                   ((get-keys-write)                        (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl
                   
                   ;; SERVERS
                   ((start-server)                    (apply server:kind-run params))
                   ((kill-server)                     (set! *server-run* #f))








|



|





|










>
>







157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
    ((not (vector? dat))                    ;; it is an error to not receive a vector
     (vector #f (vector #f "remote must be called with a vector")))
    ((> *api-process-request-count* 20) ;; 20)
     (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.")
     (set! *server-overloaded* #t)
     (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor!
    (else  
     (let* ((cmd-in            (common:safe-vector-ref dat 0 'nocmd))
            (cmd               (if (symbol? cmd-in)
				   cmd-in
				   (string->symbol cmd-in)))
            (params            (common:safe-vector-ref dat 1 '()))
            (start-t           (current-milliseconds))
            (readonly-mode     (dbr:dbstruct-read-only dbstruct))
            (readonly-command  (member cmd api:read-only-queries))
            (writecmd-in-readonly-mode (and readonly-mode (not readonly-command)))
            #;(foo               (begin
                                 #;(common:telemetry-log (conc "api-in:"(->string cmd))
                                                       payload: `((params . ,params)))
                                 
                                 #t))
            (res    
             (if writecmd-in-readonly-mode
                 (conc "attempt to run write command "cmd" on a read-only database")
                 (case cmd
                   ;;===============================================
                   ;; READ/WRITE QUERIES
                   ;;===============================================

		   ((nocmd)                         '(#f "All broken!"))

                   ((get-keys-write)                        (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl
                   
                   ;; SERVERS
                   ((start-server)                    (apply server:kind-run params))
                   ((kill-server)                     (set! *server-run* #f))

254
255
256
257
258
259
260



261
262
263
264
265
266
267
268
269
270
271
272
273
274
                   ((tasks-get-last)            (apply tasks:get-last dbstruct params))

		   ;; NO SYNC DB
		   ((no-sync-set)               (apply db:no-sync-set         *no-sync-db* params))
		   ((no-sync-get/default)       (apply db:no-sync-get/default *no-sync-db* params))
		   ((no-sync-del!)              (apply db:no-sync-del!        *no-sync-db* params))
		   ((no-sync-get-lock)          (apply db:no-sync-get-lock    *no-sync-db* params))



		   
                   ;; ARCHIVES
                   ;; ((archive-get-allocations)   
                   ((archive-register-disk)     (apply db:archive-register-disk dbstruct params))
                   ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
                   ;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))

                   ;;======================================================================
                   ;; READ ONLY QUERIES
                   ;;======================================================================

                   ;; KEYS
                   ((get-key-val-pairs)               (apply db:get-key-val-pairs dbstruct params))
                   ((get-keys)                        (db:get-keys dbstruct))







>
>
>






|







256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
                   ((tasks-get-last)            (apply tasks:get-last dbstruct params))

		   ;; NO SYNC DB
		   ((no-sync-set)               (apply db:no-sync-set         *no-sync-db* params))
		   ((no-sync-get/default)       (apply db:no-sync-get/default *no-sync-db* params))
		   ((no-sync-del!)              (apply db:no-sync-del!        *no-sync-db* params))
		   ((no-sync-get-lock)          (apply db:no-sync-get-lock    *no-sync-db* params))
		   ((no-sync-add-job)           (apply db:no-sync-add-job     *no-sync-db* params))
		   ((no-sync-take-job)          (apply db:no-sync-take-job    *no-sync-db* params))
		   ((no-sync-job-records-clean) (apply db:no-sync-job-records-clean *no-sync-db* params))
		   
                   ;; ARCHIVES
                   ;; ((archive-get-allocations)   
                   ((archive-register-disk)     (apply db:archive-register-disk dbstruct params))
                   ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
                   ;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))
		   
                   ;;======================================================================
                   ;; READ ONLY QUERIES
                   ;;======================================================================

                   ;; KEYS
                   ((get-key-val-pairs)               (apply db:get-key-val-pairs dbstruct params))
                   ((get-keys)                        (db:get-keys dbstruct))
384
385
386
387
388
389
390


391
392
393
394
395
396
397
;;
(define (api:process-request dbstruct $) ;; the $ is the request vars proc
  (debug:print 4 *default-log-port* "server-id:"  *server-id*)
  (let* ((cmd     ($ 'cmd))
	 (paramsj ($ 'params))
         (key     ($ 'key))   
	 (params  (db:string->obj paramsj transport: 'http))) ;; incoming data from the POST (or is it a GET?)


    (debug:print 4 *default-log-port* "cmd:" cmd " with params " params "key " key)
    (if (equal? key *server-id*)
      (begin
        (set! *api-process-request-count* (+ *api-process-request-count* 1))
 	(let* ((resdat  (api:execute-requests dbstruct (vector cmd params))) ;; process the request, resdat = #( flag result )
	       (success (vector-ref resdat 0))
	       (res     (vector-ref resdat 1))) ;; (vector flag payload), get the payload, ignore the flag (why?)







>
>







389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
;;
(define (api:process-request dbstruct $) ;; the $ is the request vars proc
  (debug:print 4 *default-log-port* "server-id:"  *server-id*)
  (let* ((cmd     ($ 'cmd))
	 (paramsj ($ 'params))
         (key     ($ 'key))   
	 (params  (db:string->obj paramsj transport: 'http))) ;; incoming data from the POST (or is it a GET?)
	 (success (common:safe-vector-ref resdat 0 #f))
	 (res     (common:safe-vector-ref resdat 1 #f))) ;; (vector flag payload), get the payload, ignore the flag (why?)
    (debug:print 4 *default-log-port* "cmd:" cmd " with params " params "key " key)
    (if (equal? key *server-id*)
      (begin
        (set! *api-process-request-count* (+ *api-process-request-count* 1))
 	(let* ((resdat  (api:execute-requests dbstruct (vector cmd params))) ;; process the request, resdat = #( flag result )
	       (success (vector-ref resdat 0))
	       (res     (vector-ref resdat 1))) ;; (vector flag payload), get the payload, ignore the flag (why?)
408
409
410
411
412
413
414
415
416


	  ;;          (number? res)
	  ;;          (boolean? res))
	  ;;      res 
	  ;;      (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
	  (db:obj->string res transport: 'http)))
	(begin
	  (debug:print 0 *default-log-port*   "Server refused to process request. Sever id mismatch. recived " key " expected:  " *server-id* ".\nOther arguments recived: cmd=" cmd " params = " params) 
	  (db:obj->string (conc "Server refused to process request server-id mismatch: " key ", " *server-id*) transport: 'http)))))










|

>
>
415
416
417
418
419
420
421
422
423
424
425
	  ;;          (number? res)
	  ;;          (boolean? res))
	  ;;      res 
	  ;;      (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
	  (db:obj->string res transport: 'http)))
	(begin
	  (debug:print 0 *default-log-port*   "Server refused to process request. Sever id mismatch. recived " key " expected:  " *server-id* ".\nOther arguments recived: cmd=" cmd " params = " params) 
	  (db:obj->string (conc "Server refused to process request server-id mismatch: " key ", " *server-id*) transport: 'http))))



Modified cgisetup/models/pgdb.scm from [4136225c9c] to [b49201d65c].

175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
      state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=?,last_update=?,publish_time=?  
     WHERE id=? and area_id=?;"
   state status owner event-time comment fail-count pass-count last_update publish-time run-id area-id ))

;; given all needed info create run record
;;
(define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time)
    (dbi:exec
   dbh
   "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count,area_id,last_update,publish_time)
      VALUES (?,?,?,?,?,?,?,?,?,?,?,?, ?);"
    ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time))

;;======================================================================
;;  T E S T - S T E P S
;;======================================================================

(define (pgdb:get-test-step-id dbh test-id stepname state)
  (dbi:get-one







|



|







175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
      state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=?,last_update=?,publish_time=?  
     WHERE id=? and area_id=?;"
   state status owner event-time comment fail-count pass-count last_update publish-time run-id area-id ))

;; given all needed info create run record
;;
(define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time)
  (dbi:exec
   dbh
   "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count,area_id,last_update,publish_time)
      VALUES (?,?,?,?,?,?,?,?,?,?,?,?, ?);"
   ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time))

;;======================================================================
;;  T E S T - S T E P S
;;======================================================================

(define (pgdb:get-test-step-id dbh test-id stepname state)
  (dbi:get-one

Modified chicken.makefile from [4ef647f9d5] to [b07a513938].

21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
# Chicken build
#======================================================================

# CHICKEN_BIN_DIR=$(shell dirname $(shell which csi))
# if have csi on path use that, else use default
# CSIPATH=$(shell which csi)
# CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))
sCHICKEN_PREFIX=$(or $(CKPATH),$(PREFIX)/bin/.$(ARCHSTR))

whatever :
	@echo "CHICKEN_PREFIX=$(CHICKEN_PREFIX)"

tgz-$(USER)/postgresql-9.6.4.tar.gz :
	mkdir -p tgz-$(USER)
	wget -c https://ftp.postgresql.org/pub/source/v9.6.4/postgresql-9.6.4.tar.gz







|







21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
# Chicken build
#======================================================================

# CHICKEN_BIN_DIR=$(shell dirname $(shell which csi))
# if have csi on path use that, else use default
# CSIPATH=$(shell which csi)
# CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))
CHICKEN_PREFIX=$(or $(CKPATH),$(PREFIX)/bin/.$(ARCHSTR))

whatever :
	@echo "CHICKEN_PREFIX=$(CHICKEN_PREFIX)"

tgz-$(USER)/postgresql-9.6.4.tar.gz :
	mkdir -p tgz-$(USER)
	wget -c https://ftp.postgresql.org/pub/source/v9.6.4/postgresql-9.6.4.tar.gz
64
65
66
67
68
69
70

71
72
73
74
75
76
77
	cd tgz-$(USER)/nanomsg-1.0.0; mkdir build-$(USER); cd build-$(USER);
	cd tgz-$(USER)/nanomsg-1.0.0/build-$(USER); cmake ../ -DCMAKE_INSTALL_PREFIX=$(CHICKEN_PREFIX)
	cd tgz-$(USER)/nanomsg-1.0.0/build-$(USER); make; make install

$(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE : tgz-$(USER)/chicken-4.13.0.tar.gz
	mkdir -p build-$(USER)/eggs-installed
	cd build-$(USER);tar xf ../tgz-$(USER)/chicken-4.13.0.tar.gz


tgz-$(USER)/opensrc.fossil :
	cd tgz-$(USER); fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil
	mkdir tgz-$(USER)/opensrc
	cd tgz-$(USER)/opensrc; fossil open --nested ../opensrc.fossil; fossil up; fossil uv sync

$(CHICKEN_PREFIX)/lib/libiupweb.so : tgz-$(USER)/opensrc.fossil







>







64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
	cd tgz-$(USER)/nanomsg-1.0.0; mkdir build-$(USER); cd build-$(USER);
	cd tgz-$(USER)/nanomsg-1.0.0/build-$(USER); cmake ../ -DCMAKE_INSTALL_PREFIX=$(CHICKEN_PREFIX)
	cd tgz-$(USER)/nanomsg-1.0.0/build-$(USER); make; make install

$(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE : tgz-$(USER)/chicken-4.13.0.tar.gz
	mkdir -p build-$(USER)/eggs-installed
	cd build-$(USER);tar xf ../tgz-$(USER)/chicken-4.13.0.tar.gz
	if [[ -e $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE ]];then touch $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE;fi

tgz-$(USER)/opensrc.fossil :
	cd tgz-$(USER); fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil
	mkdir tgz-$(USER)/opensrc
	cd tgz-$(USER)/opensrc; fossil open --nested ../opensrc.fossil; fossil up; fossil uv sync

$(CHICKEN_PREFIX)/lib/libiupweb.so : tgz-$(USER)/opensrc.fossil
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
	cd tgz-$(USER); tar -xzvf ffcall.tar.gz 
	cd tgz-$(USER)/ffcall; ./configure --prefix=$(CHICKEN_PREFIX) --enable-shared
	cd tgz-$(USER)/ffcall; make CC="gcc -fPIC"; make install	

$(CHICKEN_PREFIX)/bin/sqlite3 : build-$(USER)/sqlite-autoconf-3090200/configure 
	cd build-$(USER)/sqlite-autoconf-3090200; ./configure --prefix=$(CHICKEN_PREFIX); make; make install

$(CHICKEN_PREFIX)/bin/csi : $(CHICKEN_PREFIX)/bin/sqlite3 $(CHICKEN_PREFIX)/lib/libiupweb.so $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE
	cd build-$(USER)/chicken-4.13.0;make PLATFORM=linux PREFIX=$(CHICKEN_PREFIX) 
	cd build-$(USER)/chicken-4.13.0;make PLATFORM=linux PREFIX=$(CHICKEN_PREFIX) install

ALL_CKBIN=chicken chicken-bind chicken-bug chicken-dump			\
chicken-install chicken-profile chicken-sqlite3 chicken-status		\
chicken-uninstall csc csi feathers nanocat sqlite3 vacuumdb logpro	\
refdb

CKBIN_WRAPPERS=$(addprefix $(PREFIX)/bin/,$(ALL_CKBIN))

$(PREFIX)/bin/% : $(CHICKEN_PREFIX)/bin/% $(CHICKEN_PREFIX)/bin/csi $(EGGSTARG2)
	utils/mk_wrapper_tool $(PREFIX) $* $(PREFIX)/bin/$*
	chmod a+x $(PREFIX)/bin/$*

$(PREFIX)/bin :
	mkdir -p $(PREFIX)/bin $(CHICKEN_PREFIX)/bin


chicken : $(PREFIX)/bin $(CHICKEN_PREFIX)/bin/csi  binwrappers
	@echo "Fake target to build prefix chicken"

binwrappers : $(CKBIN_WRAPPERS)








postgresql.done : $(CHICKEN_PREFIX)/bin/pg_config
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib -L$(CHICKEN_PREFIX)/lib64" $(CHICKEN_PREFIX)/bin/chicken-install postgresql > postgresql.done


nanomsg.done : $(CHICKEN_PREFIX)/lib/libnanomsg.so





	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib -L$(CHICKEN_PREFIX)/lib64" $(CHICKEN_PREFIX)/bin/chicken-install nanomsg > nanomsg.done

iup.done : $(CHICKEN_PREFIX)/lib/libcallback.a
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install -D no-library-checks -feature disable-iup-web -feature disable-iup-pplot -feature disable-iup-matrixex iup > iup.done

canvas-draw.done :
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install -D no-library-checks canvas-draw > canvas-draw.done








sqlite3.done :
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install sqlite3 > sqlite3.done

sql-de-lite.done :
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install sql-de-lite > sql-de-lite.done

dbi.done : postgresql.done sqlite3.done sql-de-lite.done
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install dbi > dbi.done







|










|






>
|




>
>
>
>
>
>
>
|


>
|
>
>
>
>
>








>
>
>
>
>
>
>
|







100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
	cd tgz-$(USER); tar -xzvf ffcall.tar.gz 
	cd tgz-$(USER)/ffcall; ./configure --prefix=$(CHICKEN_PREFIX) --enable-shared
	cd tgz-$(USER)/ffcall; make CC="gcc -fPIC"; make install	

$(CHICKEN_PREFIX)/bin/sqlite3 : build-$(USER)/sqlite-autoconf-3090200/configure 
	cd build-$(USER)/sqlite-autoconf-3090200; ./configure --prefix=$(CHICKEN_PREFIX); make; make install

$(CHICKEN_PREFIX)/bin/csi : $(SQLITE3_DEP) $(CHICKEN_PREFIX)/lib/libiupweb.so $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE
	cd build-$(USER)/chicken-4.13.0;make PLATFORM=linux PREFIX=$(CHICKEN_PREFIX) 
	cd build-$(USER)/chicken-4.13.0;make PLATFORM=linux PREFIX=$(CHICKEN_PREFIX) install

ALL_CKBIN=chicken chicken-bind chicken-bug chicken-dump			\
chicken-install chicken-profile chicken-sqlite3 chicken-status		\
chicken-uninstall csc csi feathers nanocat sqlite3 vacuumdb logpro	\
refdb

CKBIN_WRAPPERS=$(addprefix $(PREFIX)/bin/,$(ALL_CKBIN))

$(PREFIX)/bin/% : $(CHICKEN_PREFIX)/bin/% $(CHICKEN_PREFIX)/bin/csi
	utils/mk_wrapper_tool $(PREFIX) $* $(PREFIX)/bin/$*
	chmod a+x $(PREFIX)/bin/$*

$(PREFIX)/bin :
	mkdir -p $(PREFIX)/bin $(CHICKEN_PREFIX)/bin

# For the future -   binwrappers
chicken : $(PREFIX)/bin $(CHICKEN_PREFIX)/bin/csi  postgresql.done nanomsg.done iup.done canvas-draw.done sqlite3.done sql-de-lite.done dbi.done  $(EGGSTARG2)
	@echo "Fake target to build prefix chicken"

binwrappers : $(CKBIN_WRAPPERS)

# make the dep a dummy if not requiring our own build of postgres
ifeq ($(BUILD_POSTGRES),yes)
PG_DEP=$(CHICKEN_PREFIX)/bin/pg_config
else
PG_DEP=$(CHICKEN_PREFIX)/bin/csi
endif

postgresql.done : $(PG_DEP)
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib -L$(CHICKEN_PREFIX)/lib64" $(CHICKEN_PREFIX)/bin/chicken-install postgresql > postgresql.done

ifeq ($(BUILD_NANOMSG),yes)
NMSG_DEP=$(CHICKEN_PREFIX)/lib/libnanomsg.so
else
NMSG_DEP=$(CHICKEN_PREFIX)/bin/csi
endif

nanomsg.done : $(NMSG_DEP)
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib -L$(CHICKEN_PREFIX)/lib64" $(CHICKEN_PREFIX)/bin/chicken-install nanomsg > nanomsg.done

iup.done : $(CHICKEN_PREFIX)/lib/libcallback.a
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install -D no-library-checks -feature disable-iup-web -feature disable-iup-pplot -feature disable-iup-matrixex iup > iup.done

canvas-draw.done :
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install -D no-library-checks canvas-draw > canvas-draw.done

# make the dep a dummy if not requiring our own build of postgres
ifeq ($(BUILD_SQLITE3),yes)
SQLITE3_DEP=$(CHICKEN_PREFIX)/bin/sqlite3
else
SQLITE3_DEP=$(CHICKEN_PREFIX)/bin/csi
endif

sqlite3.done : $(SQLITE3_DEP)
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install sqlite3 > sqlite3.done

sql-de-lite.done :
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install sql-de-lite > sql-de-lite.done

dbi.done : postgresql.done sqlite3.done sql-de-lite.done
	CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install dbi > dbi.done

Modified common.scm from [37b673dcbd] to [4f78a11800].

496
497
498
499
500
501
502










503
504
505
506
507
508
509
        (when (>= (age-wks daysfile) 1)
          (copy daysfile wksfile)
          (copy hrsfile daysfile))
        #t)
      #f))

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










;; Rotate logs, logic: 
;;                 if > 500k and older than 1 week:
;;                     remove previous compressed log and compress this log
;; WARNING: This proc operates assuming that it is in the directory above the
;;          logs directory you wish to log-rotate.
;;
(define (common:rotate-logs)







>
>
>
>
>
>
>
>
>
>







496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
        (when (>= (age-wks daysfile) 1)
          (copy daysfile wksfile)
          (copy hrsfile daysfile))
        #t)
      #f))

;;======================================================================
(define (common:safe-vector-ref vec indx default)
  (if (vector? vec)
      (handle-exceptions
	  exn
	(begin
	  (debug:print-info 0 *default-log-port* "remote data issue: exn=" exn)
	  default)
	(vector-ref vec indx))
      default))

;; Rotate logs, logic: 
;;                 if > 500k and older than 1 week:
;;                     remove previous compressed log and compress this log
;; WARNING: This proc operates assuming that it is in the directory above the
;;          logs directory you wish to log-rotate.
;;
(define (common:rotate-logs)
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
	    (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct)
	    (cond
	     ((dbr:dbstruct-read-only dbstruct)
	      (debug:print-info 13 *default-log-port* "loading read-only watchdog")
	      (common:readonly-watchdog dbstruct))
	     (else
	      (debug:print-info 13 *default-log-port* "loading writable-watchdog.")
              (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "brute-force-sync")))
                (cond
                 ((equal? syncer "brute-force-sync")
                  (server:writable-watchdog-bruteforce dbstruct))
                 ((equal? syncer "delta-sync")
                  (server:writable-watchdog-deltasync dbstruct))
                 (else
                  (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are brute-force-sync and delta-sync.")







|







1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
	    (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct)
	    (cond
	     ((dbr:dbstruct-read-only dbstruct)
	      (debug:print-info 13 *default-log-port* "loading read-only watchdog")
	      (common:readonly-watchdog dbstruct))
	     (else
	      (debug:print-info 13 *default-log-port* "loading writable-watchdog.")
              (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "delta-sync"))) ;; "brute-force-sync")))
                (cond
                 ((equal? syncer "brute-force-sync")
                  (server:writable-watchdog-bruteforce dbstruct))
                 ((equal? syncer "delta-sync")
                  (server:writable-watchdog-deltasync dbstruct))
                 (else
                  (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are brute-force-sync and delta-sync.")
2673
2674
2675
2676
2677
2678
2679


2680
2681
2682
2683
2684
2685
2686
  "returns alist mapping string keys in testconfig/subrun to megatest command line switches; if flavor is switch-symbol, maps tcmt symbolic switches to megatest switches"
  (let ((default '(("tag-expr"  . "-tagexpr")
                   ("mode-patt" . "-modepatt")
                   ("run-name"  . "-runname")
                   ("contour"   . "-contour")
                   ("target"    . "-target")
                   ("test-patt" . "-testpatt")


                   ("msg"       . "-m")
                   ("log"       . "-log")
                   ("start-dir" . "-start-dir")
                   ("new"       . "-set-state-status"))))
    (if (eq? flavor 'switch-symbol)
        (map (lambda (x)
               (cons (string->symbol (conc "-" (car x))) (cdr x)))







>
>







2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
  "returns alist mapping string keys in testconfig/subrun to megatest command line switches; if flavor is switch-symbol, maps tcmt symbolic switches to megatest switches"
  (let ((default '(("tag-expr"  . "-tagexpr")
                   ("mode-patt" . "-modepatt")
                   ("run-name"  . "-runname")
                   ("contour"   . "-contour")
                   ("target"    . "-target")
                   ("test-patt" . "-testpatt")
		   ("rerun"     . "-rerun")
		   ("setvars"   . "-setvars")
                   ("msg"       . "-m")
                   ("log"       . "-log")
                   ("start-dir" . "-start-dir")
                   ("new"       . "-set-state-status"))))
    (if (eq? flavor 'switch-symbol)
        (map (lambda (x)
               (cons (string->symbol (conc "-" (car x))) (cdr x)))
2752
2753
2754
2755
2756
2757
2758





























2759
2760
2761
2762
2763
2764
2765
     ((string? proc)(system proc))
     (proc          (proc)))
    (hash-table-for-each
     vars
     (lambda (var val)
       (setenv var val)))
    vars))






























(define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f))
  (let* ((pre-cmd  (dtests:get-pre-command))
         (post-cmd (dtests:get-post-command))
         (fullcmd  (if (or pre-cmd post-cmd)
                       (conc pre-cmd cmd post-cmd)
                       (conc "viewscreen " cmd))))







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







2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
     ((string? proc)(system proc))
     (proc          (proc)))
    (hash-table-for-each
     vars
     (lambda (var val)
       (setenv var val)))
    vars))

(define (common:propogate-mt-vars-to-subrun proc propogate-vars)
  (let ((vars      (make-hash-table))
        (var-patt  "^MT_.*"))
    (for-each
     (lambda (vardat) ;; each env var
       ;(for-each
      ;(lambda (var-patt)
	  (if (string-match var-patt (car vardat))
	      (let ((var (car vardat))
		    (val (cdr vardat)))
		(hash-table-set! vars var val)
                 (if (member var propogate-vars)
                  (begin
                  (print var "  " (string-substitute "MT_" "PARENT_" var))
                  (setenv (string-substitute "MT_" "PARENT_"  var) val)))
		(unsetenv var))))
;	var-patts))
     (get-environment-variables))
    (cond
     ((string? proc)(system proc))
     (proc          (proc)))
    (hash-table-for-each
     vars
     (lambda (var val)
         (if (member var propogate-vars)
         (unsetenv (string-substitute "MT_" "PARENT_" var)))  
       (setenv var val)))
    vars))

(define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f))
  (let* ((pre-cmd  (dtests:get-pre-command))
         (post-cmd (dtests:get-post-command))
         (fullcmd  (if (or pre-cmd post-cmd)
                       (conc pre-cmd cmd post-cmd)
                       (conc "viewscreen " cmd))))
3221
3222
3223
3224
3225
3226
3227


3228
3229
3230


3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246

3247



3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262

3263
3264
3265
3266
3267
3268
3269
3270
3271

3272
3273
3274
3275
3276
3277
3278
3279


3280
3281
3282
3283
3284
3285
3286
3287
;; 
;; [hosts]
;; arm cubie01 cubie02
;; x86_64 zeus xena myth01
;; allhosts #{g hosts arm} #{g hosts x86_64}
;; 
;; [host-types]


;; general #MTLOWESTLOAD #{g hosts allhosts}
;; arm     #MTLOWESTLOAD #{g hosts arm}
;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo


;;
;; [host-rules]
;; # maxnload   => max normalized load
;; # maxnjobs   => max jobs per cpu
;; # maxjobrate => max jobs per second
;; general maxnload=1.1; maxnjobs=1.2; maxjobrate=0.1 
;; 
;; [launchers]
;; envsetup general
;; xor/%/n 4C16G
;; % nbgeneral
;; 
;; [jobtools]
;; # if defined and not "no" flexi-launcher will bypass "launcher" unless no match.
;; flexi-launcher yes  
;; launcher nbfake

;;



(define (common:get-launcher configdat testname itempath)
  (let ((fallback-launcher (configf:lookup configdat "jobtools" "launcher")))
    (if (and (configf:lookup configdat "jobtools" "flexi-launcher") ;; overrides launcher
	     (not (equal? (configf:lookup configdat "jobtools" "flexi-launcher") "no")))
	(let* ((launchers         (hash-table-ref/default configdat "launchers" '())))
	  (if (null? launchers)
	      fallback-launcher
	      (let loop ((hed (car launchers))
			 (tal (cdr launchers)))
		(let ((patt      (car hed))
		      (host-type (cadr hed)))
		  (if (tests:match patt testname itempath)
		      (begin
			(debug:print-info 2 *default-log-port* "Have flexi-launcher match for " testname "/" itempath " = " host-type)
			(let ((launcher (configf:lookup configdat "host-types" host-type)))

			  (if launcher
			      (let* ((launcher-parts (string-split launcher))
				     (launcher-exe   (car launcher-parts)))
				(if (equal? launcher-exe "#MTLOWESTLOAD") ;; this is our special case, we will find the lowest load and craft a nbfake commandline
				    (let host-loop ((targ-host (common:get-least-loaded-host (cdr launcher-parts) host-type configdat))
						    (count     100))
				      (if targ-host
					  (conc "remrun " targ-host)
					  (if (> count 0)

					      (begin
						(debug:print 0 *default-log-port* "INFO: Waiting for a host for host-type " host-type)
						(thread-sleep! (- 101 count))
						(host-loop (common:get-least-loaded-host (cdr launcher-parts) host-type configdat)
							   (- count 1)))
					      (begin
						(debug:print 0 *default-log-port* "FATAL: Failed to find a host from #MTLOWESTLOAD for host-type " host-type)
						(exit)))))


				    launcher))
			      (begin
				(debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type)
				(if (null? tal)
				    fallback-launcher
				    (loop (car tal)(cdr tal)))))))
		      ;; no match, try again
		      (if (null? tal)







>
>



>
>









|






>
|
>
>
>
|










|


|
>









>








>
>
|







3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
;; 
;; [hosts]
;; arm cubie01 cubie02
;; x86_64 zeus xena myth01
;; allhosts #{g hosts arm} #{g hosts x86_64}
;; 
;; [host-types]
;; C/M/A      lets megatest know this launcher provides C cores, M bytes memory for architecture A 
;; 2/2G/arm   smart -cores 2 -memory 2G -arch arm
;; general #MTLOWESTLOAD #{g hosts allhosts}
;; arm     #MTLOWESTLOAD #{g hosts arm}
;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo
;;
;; NOTE: host-rules is ONLY used for MTLOWESTLOAD
;;
;; [host-rules]
;; # maxnload   => max normalized load
;; # maxnjobs   => max jobs per cpu
;; # maxjobrate => max jobs per second
;; general maxnload=1.1; maxnjobs=1.2; maxjobrate=0.1 
;; 
;; [launchers]
;; envsetup general
;; xor/%/n 2/2G/arm
;; % nbgeneral
;; 
;; [jobtools]
;; # if defined and not "no" flexi-launcher will bypass "launcher" unless no match.
;; flexi-launcher yes  
;; launcher nbfake
;; mode adjutant|normal (default is normal)
;; 
;;
;; mode is 'normal (i.e. directly use launcher) or 'adjutant (i.e. use adjutant)
;;
(define (common:get-launcher configdat testname itempath mode)
  (let ((fallback-launcher (configf:lookup configdat "jobtools" "launcher")))
    (if (and (configf:lookup configdat "jobtools" "flexi-launcher") ;; overrides launcher
	     (not (equal? (configf:lookup configdat "jobtools" "flexi-launcher") "no")))
	(let* ((launchers         (hash-table-ref/default configdat "launchers" '())))
	  (if (null? launchers)
	      fallback-launcher
	      (let loop ((hed (car launchers))
			 (tal (cdr launchers)))
		(let ((patt      (car hed))
		      (host-type (cadr hed)))
		  (if (tests:match patt testname itempath) ;; have a launcher match for this test
		      (begin
			(debug:print-info 2 *default-log-port* "Have flexi-launcher match for " testname "/" itempath " = " host-type)
			(let ((launcher (configf:lookup configdat "host-types" host-type))) ;; find the actual launcher from the host-types table
			  ;; if we are in adjutant mode then we want to return both host-type and launcher
			  (if launcher
			      (let* ((launcher-parts (string-split launcher))
				     (launcher-exe   (car launcher-parts)))
				(if (equal? launcher-exe "#MTLOWESTLOAD") ;; this is our special case, we will find the lowest load and craft a nbfake commandline
				    (let host-loop ((targ-host (common:get-least-loaded-host (cdr launcher-parts) host-type configdat))
						    (count     100))
				      (if targ-host
					  (conc "remrun " targ-host)
					  (if (> count 0)
					      
					      (begin
						(debug:print 0 *default-log-port* "INFO: Waiting for a host for host-type " host-type)
						(thread-sleep! (- 101 count))
						(host-loop (common:get-least-loaded-host (cdr launcher-parts) host-type configdat)
							   (- count 1)))
					      (begin
						(debug:print 0 *default-log-port* "FATAL: Failed to find a host from #MTLOWESTLOAD for host-type " host-type)
						(exit)))))
				    (case mode
				      ((adjutant) (list host-type launcher))
				      (else       launcher))))
			      (begin
				(debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type)
				(if (null? tal)
				    fallback-launcher
				    (loop (car tal)(cdr tal)))))))
		      ;; no match, try again
		      (if (null? tal)

Modified configf.scm from [b768bf346e] to [ee46008f99].

785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
    ht))

;; if 
(define (configf:read-alist fname)
  (handle-exceptions
      exn
    (begin
      (debug:print 0 *default-log-port* "read of alist " fname " failed. exn=" exn)
      #f)
    (configf:alist->config
     (with-input-from-file fname read))))

(define (configf:write-alist cdat fname)
  (if (not (common:faux-lock fname))
      (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname))







|







785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
    ht))

;; if 
(define (configf:read-alist fname)
  (handle-exceptions
      exn
    (begin
      (debug:print-info 0 *default-log-port* "unable to read alist " fname ". exn=" exn)
      #f)
    (configf:alist->config
     (with-input-from-file fname read))))

(define (configf:write-alist cdat fname)
  (if (not (common:faux-lock fname))
      (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname))

Modified configure from [08e182d3ee] to [5bc39a4917].

69
70
71
72
73
74
75
76
77
78
79
80
81
82
83

if [[ -e /usr/bin/sw_vers ]]; then
    ARCHSTR=$(/usr/bin/sw_vers -productVersion)
else
    ARCHSTR=$(lsb_release -sr)
fi

echo "CHICKEN_PREFIX=$PREFIX/.$ARCHSTR" >> makefile.inc
CHICKEN_PREFIX=$PREFIX/bin/.$ARCHSTR

if [[ ! $(type csi) ]];then
    echo "Chicken build needed."
    echo "BUILD_CHICKEN=yes" >> makefile.inc
    configure_dependencies
    echo "include chicken.makefile" >> makefile.inc







|







69
70
71
72
73
74
75
76
77
78
79
80
81
82
83

if [[ -e /usr/bin/sw_vers ]]; then
    ARCHSTR=$(/usr/bin/sw_vers -productVersion)
else
    ARCHSTR=$(lsb_release -sr)
fi

echo "CKPATH=$PREFIX/.$ARCHSTR" >> makefile.inc
CHICKEN_PREFIX=$PREFIX/bin/.$ARCHSTR

if [[ ! $(type csi) ]];then
    echo "Chicken build needed."
    echo "BUILD_CHICKEN=yes" >> makefile.inc
    configure_dependencies
    echo "include chicken.makefile" >> makefile.inc

Modified dashboard.scm from [8bd1a9c7d4] to [be8f9ca9ab].

1948
1949
1950
1951
1952
1953
1954











1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966




1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
                        ;;                                             userdata: (conc "run-id: " run-id))))
                        (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
                        ;; (set! colnum (+ colnum 1))
                        ))))
	      run-ids)))

(define (dashboard:tests-ht->tests-dat tests-ht)











  (reverse
   (sort
    (hash-table-values tests-ht)
    (lambda (a b) 
      (let ((a-test-name  (db:test-get-testname a))
            (a-item-path  (db:test-get-item-path a))
            (b-test-name  (db:test-get-testname b))
            (b-item-path  (db:test-get-item-path b))
            (a-event-time (db:test-get-event_time a))
            (b-event-time (db:test-get-event_time b)))
        (if (not (equal? a-test-name b-test-name))
            (> a-event-time b-event-time)




            (cond
             ((< 0 (string-compare3 a-test-name b-test-name)) #t)
             ((> 0 (string-compare3 a-test-name b-test-name)) #f)
             ((< 0 (string-compare3 a-item-path b-item-path)) #t)
             (else #f))))))))


(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash)
  (let* ((run          (hash-table-ref/default runs-hash run-id #f))
         (key-vals     (rmt:get-key-vals run-id))
         (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
         (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))







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







1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
                        ;;                                             userdata: (conc "run-id: " run-id))))
                        (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
                        ;; (set! colnum (+ colnum 1))
                        ))))
	      run-ids)))

(define (dashboard:tests-ht->tests-dat tests-ht)
  (let ((oldest-item (make-hash-table))) ;;
    ;; populate the oldest-item table
    (for-each
     (lambda (tdat)
       (let ((tname (db:test-get-testname tdat))
	     (etime (db:test-get-event_time tdat)))
	 (if (hash-table-exists? oldest-item tname)
	     (if (< (hash-table-ref oldest-item tname) etime)
		 (hash-table-set! oldest-item tname etime))
	     (hash-table-set! oldest-item tname etime))))
     (hash-table-values tests-ht))
    (reverse
     (sort
      (hash-table-values tests-ht)
      (lambda (a b) 
	(let ((a-test-name  (db:test-get-testname a))
	      (a-item-path  (db:test-get-item-path a))
	      (b-test-name  (db:test-get-testname b))
	      (b-item-path  (db:test-get-item-path b))
	      (a-event-time (db:test-get-event_time a))
	      (b-event-time (db:test-get-event_time b)))
	  (if (equal? a-test-name b-test-name)
	      (> a-event-time b-event-time)
	      (> (hash-table-ref oldest-item a-test-name)
		 (hash-table-ref oldest-item b-test-name)))))))))
;;	  (if (not (equal? a-test-name b-test-name))
;;	      (> a-event-time b-event-time)
;;	      (cond
;;	       ((< 0 (string-compare3 a-test-name b-test-name)) #t)
;;	       ((> 0 (string-compare3 a-test-name b-test-name)) #f)
;;	       ((< 0 (string-compare3 a-item-path b-item-path)) #t)
;;	       (else #f)))))))))


(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash)
  (let* ((run          (hash-table-ref/default runs-hash run-id #f))
         (key-vals     (rmt:get-key-vals run-id))
         (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
         (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
2063
2064
2065
2066
2067
2068
2069


2070
2071
2072
2073
2074
2075
2076

                (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL")))
                    (iup:attribute-set! run-matrix "NUMCOL" max-col ))

                (let ((effective-max-row (if (< max-row max-visible) max-visible max-row)))
                  (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN")))
                      (iup:attribute-set! run-matrix "NUMLIN" effective-max-row )))


                
                ;; Row labels
                (for-each (lambda (ind)
                            (let* ((name (car ind))
                                   (num  (cadr ind))
                                   (key  (conc num ":0")))
                              (if (not (equal? (iup:attribute run-matrix key) name))







>
>







2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093

                (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL")))
                    (iup:attribute-set! run-matrix "NUMCOL" max-col ))

                (let ((effective-max-row (if (< max-row max-visible) max-visible max-row)))
                  (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN")))
                      (iup:attribute-set! run-matrix "NUMLIN" effective-max-row )))

		(iup:attribute-set! run-matrix "WIDTHDEF" 16)
                
                ;; Row labels
                (for-each (lambda (ind)
                            (let* ((name (car ind))
                                   (num  (cadr ind))
                                   (key  (conc num ":0")))
                              (if (not (equal? (iup:attribute run-matrix key) name))
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
                                  (begin
                                    (set! changed #t)
                                    (iup:attribute-set! run-matrix key (cadr value))
                                    (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value))))))
                          matrix-content)
                
                ;; Col labels - do after setting Cell contents so they are accounted for in the size calc.
                
                (for-each (lambda (ind)
                            (let* ((name (car ind))
                                   (num  (cadr ind))
                                   (key  (conc "0:" num)))
                              (if (not (equal? (iup:attribute run-matrix key) name))
                                  (begin
                                    (set! changed #t)
                                    (iup:attribute-set! run-matrix key name)
                                    (if (<= num max-col)
                                        (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))))
                          col-indices)
                
                (if (and (eq? pass-num 0) changed)
                    (loop 1 #t)) ;; force second pass due to column labels changing
                
                ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num)







|







|
|







2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
                                  (begin
                                    (set! changed #t)
                                    (iup:attribute-set! run-matrix key (cadr value))
                                    (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value))))))
                          matrix-content)
                
                ;; Col labels - do after setting Cell contents so they are accounted for in the size calc.

                (for-each (lambda (ind)
                            (let* ((name (car ind))
                                   (num  (cadr ind))
                                   (key  (conc "0:" num)))
                              (if (not (equal? (iup:attribute run-matrix key) name))
                                  (begin
                                    (set! changed #t)
                                    (iup:attribute-set! run-matrix key name) ;; (list->string (intersperse (string->list name) #\newline))) ;; name)
				    #;(if (<= num max-col)
                                        (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))))
                          col-indices)
                
                (if (and (eq? pass-num 0) changed)
                    (loop 1 #t)) ;; force second pass due to column labels changing
                
                ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num)

Modified db.scm from [65246b91b8] to [ea90a41ed4].

1779
1780
1781
1782
1783
1784
1785























1786
1787
1788
1789
1790
1791
1792
	  (debug:print 0 *default-log-port* "ERROR: cannot read " infile)
          (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir)
          #f
          )
        (with-input-from-file infile read-lines)
	)))
























;;  select end_time-now from
;;      (select testname,item_path,event_time+run_duration as
;;                          end_time,strftime('%s','now') as now from tests where state in
;;      ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));

(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime)
  (let* ((incompleted '())







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







1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
	  (debug:print 0 *default-log-port* "ERROR: cannot read " infile)
          (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir)
          #f
          )
        (with-input-from-file infile read-lines)
	)))

;; check duration against test-run.dat file if it exists and update the value in
;; the db if necessary
;;
(define (db:adjust-run-duration dbstruct test-id run-dir event-time run-duration)
  (let* ((datf             (conc run-dir ".mt_data/test-run.dat"))
	 (modt             (if (and (file-exists? datf)
				    (file-read-access? datf))
			       (file-modification-time datf)
			       #f)) ;; (+ event-time run-duration))))
	 (alt-run-duration (if modt
			       (- modt event-time)
			       #f)))
    (if (and alt-run-duration
	     (> alt-run-duration run-duration))
	(begin
	  (debug:print 0 *default-log-port* "Test " test-id " run duration mismatch. Setting to " alt-run-duration)
	  (db:with-db
	   dbstruct #f #f
	   (lambda (db)
	     (sqlite3:execute db "UPDATE tests SET run_duration=? WHERE id=?;" alt-run-duration test-id)
	     #t)))
	#f))) ;; #f = we did NOT adjust the time
	      
;;  select end_time-now from
;;      (select testname,item_path,event_time+run_duration as
;;                          end_time,strftime('%s','now') as now from tests where state in
;;      ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));

(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime)
  (let* ((incompleted '())
1831
1832
1833
1834
1835
1836
1837

1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853

1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
	 ;; HOWEVER: this code in run:test seems to work fine
	 ;;              (> (- (current-seconds)(+ (db:test-get-event_time testdat)
	 ;;                     (db:test-get-run_duration testdat)))
	 ;;                    600) 
	 ;; (db:delay-if-busy dbdat)
	 (sqlite3:for-each-row 
	  (lambda (test-id run-dir uname testname item-path event-time run-duration)

	    (if (and (equal? uname "n/a")
		     (equal? item-path "")) ;; this is a toplevel test
		;; what to do with toplevel? call rollup?
		(begin
		  (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
		  (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
		(begin
		  (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))
		  (debug:print-info 0 *default-log-port* "Found old test in RUNNING state, test-id="
				    test-id" exceeded running-deadtime "running-deadtime" now="(current-seconds)
				    " event-time="event-time" run-duration="run-duration))))
	  stmth1
	  run-id running-deadtime) ;; default time 720 seconds
       
	 (sqlite3:for-each-row 
	  (lambda (test-id run-dir uname testname item-path event-time run-duration)

	    (if (and (equal? uname "n/a")
		     (equal? item-path "")) ;; this is a toplevel test
		;; what to do with toplevel? call rollup?
		(begin
		  (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
		  (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
		(begin
		  (debug:print-info 0 *default-log-port* "Found old test in REMOTEHOSTSTART state, test-id=" test-id
				    " exceeded running-deadtime "running-deadtime" now="(current-seconds)" event-time="event-time
				    " run-duration="run-duration)
		  (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))))
	  stmth2
	  run-id remotehoststart-deadtime) ;; default time 230 seconds
	 
	 ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
	 ;;
	 ;; (db:delay-if-busy dbdat)
	 (sqlite3:for-each-row







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


|


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







1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
	 ;; HOWEVER: this code in run:test seems to work fine
	 ;;              (> (- (current-seconds)(+ (db:test-get-event_time testdat)
	 ;;                     (db:test-get-run_duration testdat)))
	 ;;                    600) 
	 ;; (db:delay-if-busy dbdat)
	 (sqlite3:for-each-row 
	  (lambda (test-id run-dir uname testname item-path event-time run-duration)
	    (if (not (db:adjust-run-duration dbstruct test-id run-dir event-time run-duration))
		(if (and (equal? uname "n/a")
			 (equal? item-path "")) ;; this is a toplevel test
		    ;; what to do with toplevel? call rollup?
		    (begin
		      (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
		      (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
		    (begin
		      (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))
		      (debug:print-info 0 *default-log-port* "Found old test in RUNNING state, test-id="
					test-id" exceeded running-deadtime "running-deadtime" now="(current-seconds)
					" event-time="event-time" run-duration="run-duration)))))
	  stmth1
	  run-id running-deadtime) ;; default time 720 seconds
	    
	 (sqlite3:for-each-row 
	  (lambda (test-id run-dir uname testname item-path event-time run-duration)
	    (if (not (db:adjust-run-duration dbstruct test-id run-dir event-time run-duration))
		(if (and (equal? uname "n/a")
			 (equal? item-path "")) ;; this is a toplevel test
		    ;; what to do with toplevel? call rollup?
		    (begin
		      (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
		      (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
		    (begin
		      (debug:print-info 0 *default-log-port* "Found old test in REMOTEHOSTSTART state, test-id=" test-id
					" exceeded running-deadtime "running-deadtime" now="(current-seconds)" event-time="event-time
					" run-duration="run-duration)
		      (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))))
	  stmth2
	  run-id remotehoststart-deadtime) ;; default time 230 seconds
	 
	 ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
	 ;;
	 ;; (db:delay-if-busy dbdat)
	 (sqlite3:for-each-row
2145
2146
2147
2148
2149
2150
2151

2152




2153
2154
2155















































2156
2157
2158
2159
2160
2161
2162
  (let* ((dbpath (db:dbfile-path))
	 (dbname (conc dbpath "/no-sync.db"))
	 (db-exists (common:file-exists? dbname))
	 (db     (sqlite3:open-database dbname)))
    (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
    (if (not db-exists)
	(begin

	  (sqlite3:execute db "PRAGMA synchronous = 0;")




	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));")
	  (sqlite3:execute db "PRAGMA journal_mode=WAL;")))
    db))
















































;; if we are not a server create a db handle. this is not finalized
;; so watch for problems. I'm still not clear if it is needed to manually
;; finalize sqlite3 dbs with the sqlite3 egg.
;;
(define (db:no-sync-db db-in)
  (mutex-lock! *db-access-mutex*)







>
|
>
>
>
>
|
|

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







2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
  (let* ((dbpath (db:dbfile-path))
	 (dbname (conc dbpath "/no-sync.db"))
	 (db-exists (common:file-exists? dbname))
	 (db     (sqlite3:open-database dbname)))
    (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
    (if (not db-exists)
	(begin
	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));")
	  (sqlite3:execute db "PRAGMA journal_mode=WAL;")))
    ;; MOVE THIS TABLE CREATION TO THE (begin above in about six months (it is Sep 2020 right now).
    (sqlite3:execute db "CREATE TABLE IF NOT EXISTS jobs_queue (id INTEGER PRIMARY KEY, host_type TEXT, cores INTEGER, memory TEXT, vars TEXT, exekey TEXT, cmdline TEXT, state TEXT, event_time INTEGER, last_update INTEGER);")
    ;; not sure I'll use this next one. I prefer if tests simply append to a file:
    ;;    last-update-seconds cpuload tmpspace rundirspace
    (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_extra_data (id INTEGER PRIMARY KEY, run_id INTEGER, test_id INTEGER, last_seen_running INTEGER);") 
    (sqlite3:execute db "PRAGMA synchronous = 0;")
    db))

(define (db:no-sync-add-job db-in host-type vars-list exekey cmdline)
  (sqlite3:execute (db:no-sync-db db-in) "INSERT INTO jobs_queue (host_type,vars,exekey,cmdline,state,event_time,last_update) VALUES (?,?,?,?,?,?,?);"
		   host-type
		   (with-output-to-string
		     (lambda ()
		       (write vars-list)))
		   exekey cmdline "waiting" (current-seconds)(current-seconds)))

;; find next job (waiting longest) that matches host-type - future, we'll find jobs that fit if no exact match
(define (db:no-sync-take-job db-in host-type)
  (let* ((db   (db:no-sync-db db-in))
	 (stmt1 "SELECT id,host_type,vars,exekey,cmdline,state,event_time,last_update FROM jobs_queue WHERE host_type=? AND state != 'taken' ORDER BY event_time ASC;")
	 (stmt1h (sqlite3:prepare db stmt1))
	 (stmt2  "UPDATE jobs_queue SET state='taken',last_update=? WHERE id=?;")
	 (stmt2h (sqlite3:prepare db stmt2))
	 (res    (sqlite3:with-transaction
		  db
		  (lambda ()
		    (let* ((matching-jobs (sqlite3:fold-row
					   (lambda (res . row) ;; id host-type vars exekey state event-time last-update)
					     (cons row res))
					   '()
					   stmt1h
					   host-type)))
		      (if (null? matching-jobs)
			  #f
			  (let ((choosen-one  (let loop ((tal matching-jobs)
							 (res #f)) ;; put bestest one in here
						(if (null? tal)
						    res
						    (let ((curr (car tal))
							  (rem  (cdr tal)))
						      curr) ;; here we will compare with res, if better candidate the loop with curr else loop with res
						    ))))
			    (if choosen-one ;; we need to mark it as taken
				(sqlite3:execute stmt2h (current-seconds) (car choosen-one)))
			    choosen-one)))))))
    (sqlite3:finalize! stmt1h) ;; it'd be nice to cache these and finalize on exit.
    (sqlite3:finalize! stmt2h)
    res))

;; clean out old jobs in queue, i.e. taken and event_time > 24 hrs ago
;;
(define (db:no-sync-job-records-clean db)
  (sqlite3:execute (db:no-sync-db db) "DELETE FROM jobs_queue WHERE state='taken' AND event_time < ?;" (- (current-seconds)(* 24 3600))))
		 

;; if we are not a server create a db handle. this is not finalized
;; so watch for problems. I'm still not clear if it is needed to manually
;; finalize sqlite3 dbs with the sqlite3 egg.
;;
(define (db:no-sync-db db-in)
  (mutex-lock! *db-access-mutex*)
2170
2171
2172
2173
2174
2175
2176
2177

2178
2179
2180
2181
2182
2183
2184
2185

(define (db:no-sync-set db var val)
  (sqlite3:execute (db:no-sync-db db) "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val))

(define (db:no-sync-del! db var)
  (sqlite3:execute (db:no-sync-db db) "DELETE FROM no_sync_metadat WHERE var=?;" var))

(define (db:no-sync-get/default db var default)

  (let ((res default))
    (sqlite3:for-each-row
     (lambda (val)
       (set! res val))
     (db:no-sync-db db)
     "SELECT val FROM no_sync_metadat WHERE var=?;"
     var)
    (if res







|
>
|







2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263

(define (db:no-sync-set db var val)
  (sqlite3:execute (db:no-sync-db db) "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val))

(define (db:no-sync-del! db var)
  (sqlite3:execute (db:no-sync-db db) "DELETE FROM no_sync_metadat WHERE var=?;" var))

(define (db:no-sync-get/default db-in var default)
  (let ((db  (db:no-sync-db db-in))
	(res default))
    (sqlite3:for-each-row
     (lambda (val)
       (set! res val))
     (db:no-sync-db db)
     "SELECT val FROM no_sync_metadat WHERE var=?;"
     var)
    (if res
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264




3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
       (if newstatus  (sqlite3:execute db "UPDATE tests SET status=?  WHERE id=?;" newstatus  test-id))
       (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment)
				       test-id))))))
  (mt:process-triggers dbstruct run-id test-id newstate newstatus))

;; NEW BEHAVIOR: Count tests running in all runs!
;;
(define (db:get-count-tests-running dbstruct run-id) ;; fastmode)
  (let* ((qry ;; (if fastmode
		;;   "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '') LIMIT 1;"
		  "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '');")) ;; )
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (let* ((stmth (db:get-cache-stmth dbstruct  db qry)))
       (sqlite3:first-result stmth))))))

;; NEW BEHAVIOR: Count tests running in only one run!
;;
(define (db:get-count-tests-actually-running dbstruct run-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (sqlite3:first-result
      db
      ;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ...
      ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted') AND NOT (uname = 'n/a' AND item_path = '');")
      "SELECT count(id) FROM tests WHERE state in ('RUNNING','REMOTEHOSTSTART','LAUNCHED') AND run_id=?;" 
      run-id)))) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');")

;; NEW BEHAVIOR: Look only at single run with run-id
;; 
;; (define (db:get-running-stats dbstruct run-id)
(define (db:get-count-tests-running-for-run-id dbstruct run-id) ;; fastmode)
  (let* ((qry ;; (if fastmode
		 ;;  "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? LIMIT 1;"
		  "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;")) ;; )
    (db:with-db
     dbstruct
     run-id
     #f
     (lambda (db)
       (let* ((stmth (db:get-cache-stmth dbstruct db qry)))




	 (sqlite3:first-result stmth run-id))))))

;; For a given testname how many items are running? Used to determine
;; probability for regenerating html
;;
(define (db:get-count-tests-running-for-testname dbstruct run-id testname)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (let* ((stmt "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;")
	    (stmth (db:get-cache-stmth dbstruct db stmt)))
       (sqlite3:first-result
	stmth run-id testname)))))

(define (db:get-not-completed-cnt dbstruct run-id)
(db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
      ;(print "SELECT count(id) FROM tests WHERE state not in ('COMPLETED', 'DELETED') AND run_id=" run-id)  
     (sqlite3:first-result
      db
      "SELECT count(id) FROM tests WHERE state not in ('COMPLETED', 'DELETED') AND run_id=?;" run-id))))

(define (db:get-count-tests-running-in-jobgroup dbstruct run-id jobgroup)
  (if (not jobgroup)
      0 ;; 
      (let ((testnames '()))
	;; get the testnames
	(db:with-db







|
<
<
|
|
|
|
|
|
|
|



















|
<
<
|






>
>
>
>
|












|
|


|




|
|
|
|







3296
3297
3298
3299
3300
3301
3302
3303


3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331


3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
       (if newstatus  (sqlite3:execute db "UPDATE tests SET status=?  WHERE id=?;" newstatus  test-id))
       (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment)
				       test-id))))))
  (mt:process-triggers dbstruct run-id test-id newstate newstatus))

;; NEW BEHAVIOR: Count tests running in all runs!
;;
(define (db:get-count-tests-running dbstruct run-id)


  (let* ((qry  "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '');"))
    (db:with-db
     dbstruct
     run-id
     #f
     (lambda (db)
       (let* ((stmth (db:get-cache-stmth dbstruct db qry)))
	 (sqlite3:first-result stmth))))))

;; NEW BEHAVIOR: Count tests running in only one run!
;;
(define (db:get-count-tests-actually-running dbstruct run-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (sqlite3:first-result
      db
      ;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ...
      ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted') AND NOT (uname = 'n/a' AND item_path = '');")
      "SELECT count(id) FROM tests WHERE state in ('RUNNING','REMOTEHOSTSTART','LAUNCHED') AND run_id=?;" 
      run-id)))) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');")

;; NEW BEHAVIOR: Look only at single run with run-id
;; 
;; (define (db:get-running-stats dbstruct run-id)
(define (db:get-count-tests-running-for-run-id dbstruct run-id)


  (let* ((qry "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;"))
    (db:with-db
     dbstruct
     run-id
     #f
     (lambda (db)
       (let* ((stmth (db:get-cache-stmth dbstruct db qry)))
	 (sqlite3:fold-row
	  (lambda (res val) val)
	  0 stmth run-id))))))

;;	 (sqlite3:first-result stmth run-id))))))

;; For a given testname how many items are running? Used to determine
;; probability for regenerating html
;;
(define (db:get-count-tests-running-for-testname dbstruct run-id testname)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (let* ((stmt "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;")
	    (stmth (db:get-cache-stmth dbstruct db stmt)))
       (sqlite3:fold-row
	(lambda (res val) val) 0 stmth run-id testname)))))

(define (db:get-not-completed-cnt dbstruct run-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (let* ((stmt "SELECT count(id) FROM tests WHERE state not in ('COMPLETED', 'DELETED') AND run_id=?;"))
       (sqlite3:fold-row
	(lambda (res val) val)
	0 (db:get-cache-stmth dbstruct db stmt) run-id)))))

(define (db:get-count-tests-running-in-jobgroup dbstruct run-id jobgroup)
  (if (not jobgroup)
      0 ;; 
      (let ((testnames '()))
	;; get the testnames
	(db:with-db
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
  (let* ((run-ids (db:get-all-run-ids mtdb)))
    (for-each 
     (lambda (run-id)
       (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
	 (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs)))
     run-ids)))

;; Get test data using test_id, run-id is not used
;; 
(define (db:get-test-info-by-id dbstruct run-id test-id)
  (db:with-db
   dbstruct
   #f ;; run-id
   #f
   (lambda (db)







|







3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
  (let* ((run-ids (db:get-all-run-ids mtdb)))
    (for-each 
     (lambda (run-id)
       (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
	 (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs)))
     run-ids)))

;; Get test data using test_id, run-id is not used - but it will be!
;; 
(define (db:get-test-info-by-id dbstruct run-id test-id)
  (db:with-db
   dbstruct
   #f ;; run-id
   #f
   (lambda (db)

Modified dcommon.scm from [dbcf309f44] to [eebc64bdcf].

951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968

(define (dcommon:y->canvas y scalef yoffset)
  (+ yoffset (* y scalef)))

;; sizex, sizey     - canvas size
;; originx, originy - canvas origin
;;
(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)
  (let* ((dot-data ;; (map cdr (filter
		   ;; 	  (lambda (x)(equal? "node" (car x)))
	  (map string-split (tests:lazy-dot test-records "plain" sizex sizey))) ;; (tests:easy-dot test-records "plain")))
	 (xoffset	 (dcommon:get-xoffset tests-draw-state sizex xadj))
	 (yoffset        (dcommon:get-yoffset tests-draw-state sizey yadj))
	 (no-dot         (configf:lookup *configdat* "setup" "nodot"))
	 (boxh           15)
	 (boxw           10)
	 (margin         5)
	 (tests-info     (hash-table-ref tests-draw-state 'tests-info))







|
|
<
|







951
952
953
954
955
956
957
958
959

960
961
962
963
964
965
966
967

(define (dcommon:y->canvas y scalef yoffset)
  (+ yoffset (* y scalef)))

;; sizex, sizey     - canvas size
;; originx, originy - canvas origin
;;
(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy
				    tests-draw-state sorted-testnames test-records)

  (let* ((dot-data       (tests:lazy-dot test-records "plain" sizex sizey 'munged))
	 (xoffset	 (dcommon:get-xoffset tests-draw-state sizex xadj))
	 (yoffset        (dcommon:get-yoffset tests-draw-state sizey yadj))
	 (no-dot         (configf:lookup *configdat* "setup" "nodot"))
	 (boxh           15)
	 (boxw           10)
	 (margin         5)
	 (tests-info     (hash-table-ref tests-draw-state 'tests-info))

Modified docs/manual/megatest_manual.html from [e1b85635a3] to [3faff48e96].

2669
2670
2671
2672
2673
2674
2675















2676
2677
2678
2679
2680
2681
2682
<div class="listingblock">
<div class="content monospaced">
<pre>[setup]
# this will automatically kill the test if it runs for more than 1h 2m and 3s
runtimelim 1h 2m 3s</pre>
</div></div>
</div>















</div>
</div>
<div class="sect2">
<h3 id="_tests_browser_view">Tests browser view</h3>
<div class="paragraph"><p>The tests browser (see the Run Control tab on the dashboard) has two views for displaying the tests.</p></div>
<div class="olist arabic"><ol class="arabic">
<li>







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







2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
<div class="listingblock">
<div class="content monospaced">
<pre>[setup]
# this will automatically kill the test if it runs for more than 1h 2m and 3s
runtimelim 1h 2m 3s</pre>
</div></div>
</div>
<div class="sect4">
<h5 id="_post_run_hook">Post Run Hook</h5>
<div class="paragraph"><p>This runs script to-run.sh after all tests have been completed. It is
not necessary to use -run-wait as each test will check for other
running tests on completion and if there are none it will call the
post run hook.</p></div>
<div class="paragraph"><p>Note that the output from the script call will be placed in a log file
in the logs directory with a file name derived by replacing / with _
in post-hook-&lt;target&gt;-&lt;runname&gt;.log.</p></div>
<div class="listingblock">
<div class="content monospaced">
<pre>[runs]
post-hook /path/to/script/to-run.sh</pre>
</div></div>
</div>
</div>
</div>
<div class="sect2">
<h3 id="_tests_browser_view">Tests browser view</h3>
<div class="paragraph"><p>The tests browser (see the Run Control tab on the dashboard) has two views for displaying the tests.</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
3245
3246
3247
3248
3249
3250
3251











3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263













































3264
3265
3266
3267
3268
3269
3270



3271





3272



3273
3274
3275
3276
3277
3278
3279
testname1/itempath A comment about why it was waived
testname2          A comment for a non-itemized test</pre>
</div></div>
</div>
</div>
<div class="sect2">
<h3 id="_ezsteps">Ezsteps</h3>











<div class="listingblock">
<div class="title">Example ezsteps with logpro rules</div>
<div class="content monospaced">
<pre>[ezsteps]
lookittmp   ls /tmp

[logpro]
lookittmp ;; Note: config file format supports multi-line entries where leading whitespace is removed from each line
  ;;     a blank line indicates the end of the block of text
  (expect:required in "LogFileBody" &gt; 0 "A file name that should never exist!" #/This is a awfully stupid file name that should never be found in the temp dir/)</pre>
</div></div>
<div class="paragraph"><p>To transfer the environment to the next step you can do the following:</p></div>













































# if your upstream file is csh you can force csh like this
# if your upstream is bash
loadenv     source $REF/ourenviron.sh

<div class="listingblock">
<div class="title">Propagate environment to next step</div>
<div class="content monospaced">



<pre>$MT_MEGATEST -env2file .ezsteps/${stepname}</pre>





</div></div>



</div>
<div class="sect2">
<h3 id="_scripts">Scripts</h3>
<div class="listingblock">
<div class="title">Specifying scripts inline (best used for only simple scripts)</div>
<div class="content monospaced">
<pre>[scripts]







>
>
>
>
>
>
>
>
>
>
>











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





|

>
>
>
|
>
>
>
>
>

>
>
>







3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
testname1/itempath A comment about why it was waived
testname2          A comment for a non-itemized test</pre>
</div></div>
</div>
</div>
<div class="sect2">
<h3 id="_ezsteps">Ezsteps</h3>
<div class="paragraph"><p>Ezsteps is the recommended way to implement tests and automation in
Megatest.</p></div>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<img src="/nfs/pdx/disks/ice.disk.002/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note">
</td>
<td class="content">Each ezstep must be a single line. Use the [scripts] mechanism
to create multiline scripts (see example below).</td>
</tr></table>
</div>
<div class="listingblock">
<div class="title">Example ezsteps with logpro rules</div>
<div class="content monospaced">
<pre>[ezsteps]
lookittmp   ls /tmp

[logpro]
lookittmp ;; Note: config file format supports multi-line entries where leading whitespace is removed from each line
  ;;     a blank line indicates the end of the block of text
  (expect:required in "LogFileBody" &gt; 0 "A file name that should never exist!" #/This is a awfully stupid file name that should never be found in the temp dir/)</pre>
</div></div>
<div class="sect3">
<h4 id="_automatic_environment_propagation_with_ezsteps">Automatic environment propagation with Ezsteps</h4>
<div class="paragraph"><p>Turn on ezpropvars and environment variables will be propagated from
step to step. Use this to source script files that modify the
envionment where the modifications are needed in subsequent steps.</p></div>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<img src="/nfs/pdx/disks/ice.disk.002/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note">
</td>
<td class="content">aliases and variables with strange whitespace or characters will
not propagate correctly. Put in a ticket on the
<a href="http://www.kiatoa.com/fossils/megatest">http://www.kiatoa.com/fossils/megatest</a> site if you need support for a
specific strange character combination.</td>
</tr></table>
</div>
<div class="listingblock">
<div class="title">Turn on auto propagate for bash</div>
<div class="content monospaced">
<pre>[setup]
ezpropvars sh</pre>
</div></div>
<div class="listingblock">
<div class="title">Write your ezsteps. The loadenv.csh step will use /bin/csh as its shell, other steps will use bash.</div>
<div class="content monospaced">
<pre>[ezsteps]
loadenv.csh source $REF/ourenviron.csh
compile make
install make install</pre>
</div></div>
<div class="paragraph"><p>Bash and csh are supported. You can override the shell binary location
from the default /bin/bash and /bin/csh if needed.</p></div>
<div class="listingblock">
<div class="title">Turn on auto propagate for csh</div>
<div class="content monospaced">
<pre>[setup]
ezpropvars csh /bin/csh</pre>
</div></div>
<div class="listingblock">
<div class="title">Example of auto propagation using extensions</div>
<div class="content monospaced">
<pre>[ezsteps]
step1.sh export SOMEVAR=$(ps -def | wc -l);ls /tmp
# The next step will get the value of $SOMEVAR from step1.sh
step2.sh echo $SOMEVAR</pre>
</div></div>
# if your upstream file is csh you can force csh like this
# if your upstream is bash
loadenv     source $REF/ourenviron.sh

<div class="listingblock">
<div class="title">Example of multi-line script</div>
<div class="content monospaced">
<pre>[scripts]
tarresults tar cfvz $DEST/srcdir1.tar.gz srcdir1
  tar cfvz $DEST/srcdir2.tar.gz srcdir2

[setup]
ezpropvars sh

[ezsteps]
step1 DEST=/tmp/targz;source tarresults</pre>
</div></div>
<div class="paragraph"><p>The above example will result in files; tarresults and ez_step1 being
created in the test dir.</p></div>
</div>
</div>
<div class="sect2">
<h3 id="_scripts">Scripts</h3>
<div class="listingblock">
<div class="title">Specifying scripts inline (best used for only simple scripts)</div>
<div class="content monospaced">
<pre>[scripts]
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
</div>
</div>
</div>
<div id="footnotes"><hr></div>
<div id="footer">
<div id="footer-text">
Version 1.5<br>
Last updated 2020-09-08 08:39:29 PDT
</div>
</div>
</body>
</html>







|




3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
</div>
</div>
</div>
<div id="footnotes"><hr></div>
<div id="footer">
<div id="footer-text">
Version 1.5<br>
Last updated 2020-10-13 21:24:33 PDT
</div>
</div>
</body>
</html>

Modified docs/manual/reference.txt from [7adc3533c3] to [174f58eb7b].

722
723
724
725
726
727
728






729
730
731
732
733
734
735
736
737
738
739
740
741

742
743
744
745
746



747






748



749

750






































751
752
753
754
755
756
757
testname1/itempath A comment about why it was waived
testname2          A comment for a non-itemized test 
---------------------------

Ezsteps
~~~~~~~







.Example ezsteps with logpro rules
-----------------
[ezsteps]
lookittmp   ls /tmp

[logpro]
lookittmp ;; Note: config file format supports multi-line entries where leading whitespace is removed from each line
  ;;     a blank line indicates the end of the block of text 
  (expect:required in "LogFileBody" > 0 "A file name that should never exist!" #/This is a awfully stupid file name that should never be found in the temp dir/)

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

To transfer the environment to the next step you can do the following:

# if your upstream file is csh you can force csh like this
# if your upstream is bash 
loadenv     source $REF/ourenviron.sh





.Propagate environment to next step






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



$MT_MEGATEST -env2file .ezsteps/${stepname}	  

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







































Scripts
~~~~~~~

.Specifying scripts inline (best used for only simple scripts)
----------------------------
[scripts]







>
>
>
>
>
>












|
>





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







722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
testname1/itempath A comment about why it was waived
testname2          A comment for a non-itemized test 
---------------------------

Ezsteps
~~~~~~~

Ezsteps is the recommended way to implement tests and automation in
Megatest.

NOTE: Each ezstep must be a single line. Use the [scripts] mechanism
to create multiline scripts (see example below).

.Example ezsteps with logpro rules
-----------------
[ezsteps]
lookittmp   ls /tmp

[logpro]
lookittmp ;; Note: config file format supports multi-line entries where leading whitespace is removed from each line
  ;;     a blank line indicates the end of the block of text 
  (expect:required in "LogFileBody" > 0 "A file name that should never exist!" #/This is a awfully stupid file name that should never be found in the temp dir/)

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

Automatic environment propagation with Ezsteps
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
# if your upstream file is csh you can force csh like this
# if your upstream is bash 
loadenv     source $REF/ourenviron.sh


Turn on ezpropvars and environment variables will be propagated from
step to step. Use this to source script files that modify the
envionment where the modifications are needed in subsequent steps.

NOTE: aliases and variables with strange whitespace or characters will
not propagate correctly. Put in a ticket on the
http://www.kiatoa.com/fossils/megatest site if you need support for a
specific strange character combination.

.Turn on auto propagate for bash
---------------------------
[setup]
ezpropvars sh
---------------------------

.Write your ezsteps. The loadenv.csh step will use /bin/csh as its shell, other steps will use bash.
---------------------------
[ezsteps]
loadenv.csh source $REF/ourenviron.csh
compile make
install make install
---------------------------

Bash and csh are supported. You can override the shell binary location
from the default /bin/bash and /bin/csh if needed.

.Turn on auto propagate for csh
---------------------------
[setup]
ezpropvars csh /bin/csh
---------------------------

.Example of auto propagation using extensions
---------------------------
[ezsteps]
step1.sh export SOMEVAR=$(ps -def | wc -l);ls /tmp
# The next step will get the value of $SOMEVAR from step1.sh
step2.sh echo $SOMEVAR
---------------------------

.Example of multi-line script
---------------------------
[scripts]
tarresults tar cfvz $DEST/srcdir1.tar.gz srcdir1
  tar cfvz $DEST/srcdir2.tar.gz srcdir2

[setup]
ezpropvars sh

[ezsteps]
step1 DEST=/tmp/targz;source tarresults
---------------------------

The above example will result in files; tarresults and ez_step1 being
created in the test dir.

Scripts
~~~~~~~

.Specifying scripts inline (best used for only simple scripts)
----------------------------
[scripts]

Modified env.scm from [028e47144f] to [c7d61e935d].

19
20
21
22
23
24
25


26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
;;======================================================================

(declare (unit env))

(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)

(define (env:open-db fname)


  (let* ((db-exists (common:file-exists? fname))
	 (db        (open-database fname)))
    (if (not db-exists)
	(begin
	  (exec (sql db "CREATE TABLE envvars (
                    id INTEGER PRIMARY KEY,
                    context TEXT NOT NULL,
                    var TEXT NOT NULL,
                    val TEXT NOT NULL,
                       CONSTRAINT envvars_constraint UNIQUE (context,var))"))))
    (set-busy-handler! db (busy-timeout 10000))
    db))

;; save vars in given context, this is NOT incremental by default
;;
(define (env:save-env-vars db context #!key (incremental #f)(vardat #f))
  (with-transaction







>
>
|



|
|
|
|
|
|







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

(declare (unit env))

(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)

(define (env:open-db fname)
  (let* ((db-exists (if (equal? fname ":memory:")
			#f
			(common:file-exists? fname)))
	 (db        (open-database fname)))
    (if (not db-exists)
	(begin
	  (exec (sql db "CREATE TABLE IF NOT EXISTS envvars (
                            id INTEGER PRIMARY KEY,
                            context TEXT NOT NULL,
                            var TEXT NOT NULL,
                            val TEXT NOT NULL,
                               CONSTRAINT envvars_constraint UNIQUE (context,var))"))))
    (set-busy-handler! db (busy-timeout 10000))
    db))

;; save vars in given context, this is NOT incremental by default
;;
(define (env:save-env-vars db context #!key (incremental #f)(vardat #f))
  (with-transaction
75
76
77
78
79
80
81























82
83
84
85
86
87
88
				  (let ((sep (cadr (assoc var paths))))
				    (env:merge-path-envvar sep (hash-table-ref result var) val))
				  val)))))
	(sql db "SELECT var,val FROM envvars WHERE context=?")
	context))
     contexts)
    result))
























;;  get list of removed variables between two contexts
;;
(define (env:get-removed db contexta contextb)
  (let ((result (make-hash-table)))
    (query
     (for-each-row







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







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
				  (let ((sep (cadr (assoc var paths))))
				    (env:merge-path-envvar sep (hash-table-ref result var) val))
				  val)))))
	(sql db "SELECT var,val FROM envvars WHERE context=?")
	context))
     contexts)
    result))

;; envdelta: a-b (start=a, end=b, get the delta)
;; ofile:    #f = write to stdout, else write to file with string name
;;
(define (env:envdelta db envdelta ofile)
  (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta)))
    (if (not (null? match))
	(let* ((parts     match) ;; (string-split equn "-"))
	       (minuend   (car parts))
	       (subtraend (cadr parts))
	       (added     (env:get-added   db minuend subtraend))
	       (removed   (env:get-removed db minuend subtraend))
	       (changed   (env:get-changed db minuend subtraend)))
	  ;; (pp (hash-table->alist added))
	  ;; (pp (hash-table->alist removed))
	  ;; (pp (hash-table->alist changed))
	  (if (args:get-arg "-o")
	      (with-output-to-file
		  (args:get-arg "-o")
		(lambda ()
		  (env:print added removed changed)))
	      (env:print added removed changed)))
	#f)))

;;  get list of removed variables between two contexts
;;
(define (env:get-removed db contexta contextb)
  (let ((result (make-hash-table)))
    (query
     (for-each-row

Modified ezsteps.scm from [aab87817a5] to [f490f568e7].

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

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")






;;(rmt:get-test-info-by-id run-id test-id) -> testdat











































;; TODO: deprecate me in favor of ezsteps.scm

;;
(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
  (let* ((stepname       (car ezstep))  ;; do stuff to run the step

	 (stepinfo       (cadr ezstep))













	;; (let ((info (cadr ezstep)))
	;; 		   (if (proc? info) "" info)))
	;; (stepproc       (let ((info (cadr ezstep)))
	;; 		   (if (proc? info) info #f)))
	 (stepparts      (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo))
	 (stepparams     (if (and (list? stepparts)
				  (> (length stepparts) 1))
			     (list-ref stepparts 2)
			     #f)) ;; for future use, {VAR=1,2,3}, run step for each
	 (paramparts     (if (string? stepparams)
			     (map (lambda (x)(string-split x "=")) (string-split-fields "[^;]*=[^;]*" stepparams))







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

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

|

>

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







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

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")


(define (ezsteps:step-name->mode stepname)
  (match (string-search "\\.([^\\.]+)$" stepname)
    ((_ ext) (string->symbol ext))
    (else    #f)))

(define (ezsteps:create-step-script envdbf stepname prevstepname mode cmd shellexe)
  (let* (#;(shebang (case mode
		    ((sh)  "/bin/sh")
		    ((csh) "/bin/csh")
		    (else  "/bin/bash")))
	 (sourcef (conc ".ezsteps/vars_" prevstepname "." mode))
	 (scriptn (conc "ez_" stepname))) ;; remember the name already has an extension .sh, .csh etc.
    (with-output-to-file scriptn
      (lambda ()
	;; the shebang line
	(print "#!" shellexe)
	;; save the env at start
	(print "megatest -envcap "stepname"_start "envdbf)
	;; source vars from previous steps
	(if (file-exists? sourcef)
	    (print "source " sourcef))
	;; run the command
	(print cmd)
	(if (eq? mode 'csh)
	    (print "set ecode=$?")
	    (print "ecode=$?"))
	;; save the env at end
	(print "megatest -envcap "stepname"_end "envdbf)
	;; write the delta
	(print "megatest -envdelta "stepname"_start-"stepname"_end -dumpmode bash -o .ezsteps/vars_"stepname".sh "envdbf)
	(print "megatest -envdelta "stepname"_start-"stepname"_end -dumpmode csh -o .ezsteps/vars_"stepname".csh "envdbf)
	(print "exit $ecode")))
    (system (conc "chmod a+x " scriptn))))

(define (ezsteps:get-ezpropvars res) ;; testconfig)
  ;; (let* ((res (configf:lookup testconfig "setup" "ezpropvars")))
    (if (string? res)
	(let* ((dat (string-split res)))
	  (match dat
	    ((s shellexe)
	     (let ((shl (string->symbol s)))
	       `(,shl . ,shellexe)))
	    ((s)
	     (let* ((shl      (string->symbol s))
		    (shellexe (if (eq? shl 'csh) "/bin/csh" "/bin/bash")))
	       `(,shl . ,shellexe)))
	    (else #f)))
	#f))

;; NOTE: returns logpro-used?
;;
(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat prevstepname envdbf)
  (let* ((stepname       (car ezstep))  ;; do stuff to run the step
	 (stepmode-n     (ezsteps:step-name->mode stepname))
	 (stepinfo       (cadr ezstep))
	 (shellmode      (ezsteps:get-ezpropvars  (configf:lookup testconfig "setup" "ezpropvars"))) ;; returns '(csh|sh . "/path/to/shell")
	 (stepmode       (if stepmode-n ;; the .sh or .csh always wins
			     stepmode-n
			     (if shellmode
				 (car shellmode)
				 #f)))
	 (shellexe       (if stepmode-n
			     (case stepmode
			       ((csh) "/bin/csh")
			       (else  "/bin/bash"))
			     (if shellmode
				 (cdr shellmode)
				 "/bin/bash")))
	 ;; (let ((info (cadr ezstep)))
	 ;; 		   (if (proc? info) "" info)))
	 ;; (stepproc       (let ((info (cadr ezstep)))
	 ;; 		   (if (proc? info) info #f)))
	 (stepparts      (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo))
	 (stepparams     (if (and (list? stepparts)
				  (> (length stepparts) 1))
			     (list-ref stepparts 2)
			     #f)) ;; for future use, {VAR=1,2,3}, run step for each
	 (paramparts     (if (string? stepparams)
			     (map (lambda (x)(string-split x "=")) (string-split-fields "[^;]*=[^;]*" stepparams))
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
	    (lambda ()
	      (print ";; logpro file extracted from testconfig\n"
		     ";;")
	      (print tconfig-logpro)))
	  (set! logpro-used #t)))
    
    ;; NB// can safely assume we are in test-area directory
    (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts

		 " stepparams: " stepparams " stepcmd: " stepcmd)
    


    ;; ;; first source the previous environment
    ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") 
    ;;      							 (get-environment-variable "SHELL")) ".csh" ".sh"))))
    ;;   (if (and prevstep (common:file-exists? prev-env))
    ;;       (set! script (conc script "source " prev-env))))
    
    ;; call the command using mt_ezstep
    ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd))
    
    (debug:print 4 *default-log-port* "script: " script)
    (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
    ;; now launch the actual process
    (call-with-environment-variables 
     (list (cons "PATH" (conc (get-environment-variable "PATH") ":.")))
     (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1")



       (let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1 
	      (pid #f))
	 (let ((proc (lambda ()
		       (set! pid (process-run "/bin/bash" (list "-c" cmd))))))
	   (if subrun
               (begin
                 (debug:print-info 0 *default-log-port* "Running "cmd" without MT_.* environment variables.")
                 (common:without-vars proc "^MT_.*"))
	       (proc)))
	 
         (with-output-to-file "Makefile.ezsteps"
           (lambda ()
             (print stepname ".log :")
             (print "\t" cmd)
             (if (common:file-exists? (conc stepname ".logpro"))







|
>

|
>
>















>
>
>
|






|







139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
	    (lambda ()
	      (print ";; logpro file extracted from testconfig\n"
		     ";;")
	      (print tconfig-logpro)))
	  (set! logpro-used #t)))
    
    ;; NB// can safely assume we are in test-area directory
    (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo
		 " stepparts: " stepparts
		 " stepparams: " stepparams " stepcmd: " stepcmd)

    (if stepmode (ezsteps:create-step-script envdbf stepname prevstepname stepmode stepcmd shellexe))

    ;; ;; first source the previous environment
    ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") 
    ;;      							 (get-environment-variable "SHELL")) ".csh" ".sh"))))
    ;;   (if (and prevstep (common:file-exists? prev-env))
    ;;       (set! script (conc script "source " prev-env))))
    
    ;; call the command using mt_ezstep
    ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd))
    
    (debug:print 4 *default-log-port* "script: " script)
    (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
    ;; now launch the actual process
    (call-with-environment-variables 
     (list (cons "PATH" (conc (get-environment-variable "PATH") ":.")))
     (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1")
       (let* ((cmd (conc (if stepmode
			     (conc "ez_" stepname)
			     stepcmd)
			 " > " stepname ".log 2>&1")) ;; >outfile 2>&1 
	      (pid #f))
	 (let ((proc (lambda ()
		       (set! pid (process-run "/bin/bash" (list "-c" cmd))))))
	   (if subrun
               (begin
                 (debug:print-info 0 *default-log-port* "Running "cmd" without MT_.* environment variables.")
                 (common:propogate-mt-vars-to-subrun proc '("MT_TARGET" "MT_LINKTREE" "MT_RUNNAME")))
	       (proc)))
	 
         (with-output-to-file "Makefile.ezsteps"
           (lambda ()
             (print stepname ".log :")
             (print "\t" cmd)
             (if (common:file-exists? (conc stepname ".logpro"))

Modified launch.scm from [1931a96c9c] to [2a102f22e8].

166
167
168
169
170
171
172

173


174
175
176
177
178
179
180
181
182
183
184
185
186
187
188

189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227


228
229
230
231
232
233
234
              (set! ezsteps #t) ;; set the needed flag
	      (set! ezstepslst
                    (append (or ezstepslst '())
                            (list (list "subrun" (conc "{subrun=true} " mt-cmd)))))))

	;; process the ezsteps
	(if ezsteps

	    (let* ((all-steps-dat (make-hash-table))) ;; keep all the info around as stepname ==> alist; where  'params is the params list (add other stuff as needed)


	      (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps"))
	      ;; if ezsteps was defined then we are sure to have at least one step but check anyway
	      (if (not (> (length ezstepslst) 0))
		  (debug:print-error 0 *default-log-port* "ezsteps defined but ezstepslst is zero length")
                  (let ((all-step-names (map car ezstepslst))
                        (status-file (file-open "ezsteps.status" (+ open/append open/wronly open/creat)))
                        )
		   (setenv "MT_STEP_NAMES" (string-intersperse all-step-names " "))
		   (let loop ((ezstep (car ezstepslst))
			     (tal    (cdr ezstepslst))
			     (prevstep #f))
                    (debug:print-info 0 *default-log-port* "Processing ezstep \"" (string-intersperse ezstep " ") "\"")
		    ;; check exit-info (vector-ref exit-info 1)
		    (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1)
			(let* ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat))

			       (stepname    (car ezstep))
			       (stepparms   (hash-table-ref all-steps-dat stepname)))
			  (setenv "MT_STEP_NAME" stepname)
			  (pp (hash-table->alist all-steps-dat))
			  ;; if logpro-used read in the stepname.dat file
			  (if (and logpro-used (common:file-exists? (conc stepname ".dat")))
			      (launch:load-logpro-dat run-id test-id stepname))

                          (file-write status-file (conc stepname " " (launch:einf-exit-code exit-info) "\n"))

			  (if (steprun-good? logpro-used (launch:einf-exit-code exit-info) stepparms)
			      (if (not (null? tal))
				  (loop (car tal) (cdr tal) stepname))
			      (debug:print 0 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping")))
			(debug:print 0 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))
                        (file-close status-file)
                        )

                        ))))))

(define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)
  (let* ((update-period (string->number (or (configf:lookup *configdat* "setup" "test-stats-update-period") "30")))
         (start-seconds (current-seconds))
	 (calc-minutes  (lambda ()
			  (inexact->exact 
			   (round 
			    (- 
			     (current-seconds) 
			     start-seconds)))))
	 (kill-tries 0))
    ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area)
    ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area)
    (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10)

    (let loop ((minutes   (calc-minutes))
	       (cpu-load  (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f)))
	       (disk-free (get-df (current-directory)))
               (last-sync (current-seconds)))
      ;; (common:telemetry-log "zombie" (conc "launch:monitor-job - top of loop encountered at "(current-seconds)" with last-sync="last-sync))


      (let* ((over-time     (> (current-seconds) (+ last-sync update-period)))
             (new-cpu-load  (let* ((load  (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f)))
                                   (delta (abs (- load cpu-load))))
                              (if (> delta 0.1) ;; don't bother updating with small changes
                                  load
                                  #f)))
             (new-disk-free (let* ((df    (if over-time ;; only get df every 30 seconds







>
|
>
>









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



|
|
|
|


















|






>
>







166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
              (set! ezsteps #t) ;; set the needed flag
	      (set! ezstepslst
                    (append (or ezstepslst '())
                            (list (list "subrun" (conc "{subrun=true} " mt-cmd)))))))

	;; process the ezsteps
	(if ezsteps
	    (let* ((envdbf        (conc "/tmp/."(current-user-name)"-"(current-process-id)"-"run-id"-"test-id".db"))
		   (all-steps-dat (make-hash-table))) ;; keep all the info around as stepname ==> alist;
	                                              ;;; where  'params is the params list (add other
	                                              ;;; stuff as needed)
	      (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps"))
	      ;; if ezsteps was defined then we are sure to have at least one step but check anyway
	      (if (not (> (length ezstepslst) 0))
		  (debug:print-error 0 *default-log-port* "ezsteps defined but ezstepslst is zero length")
                  (let ((all-step-names (map car ezstepslst))
                        (status-file (file-open "ezsteps.status" (+ open/append open/wronly open/creat)))
                        )
		   (setenv "MT_STEP_NAMES" (string-intersperse all-step-names " "))
		   (let loop ((ezstep (car ezstepslst))
			       (tal    (cdr ezstepslst))
			       (prevstep #f))
		      (debug:print-info 0 *default-log-port* "Processing ezstep \"" (string-intersperse ezstep " ") "\"")
		      ;; check exit-info (vector-ref exit-info 1)
		      (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1)
			  (let* ((logpro-used (launch:runstep ezstep run-id test-id exit-info m
							      tal testconfig all-steps-dat prevstep envdbf))
				 (stepname    (car ezstep))
				 (stepparms   (hash-table-ref all-steps-dat stepname)))
			    (setenv "MT_STEP_NAME" stepname)
			    (pp (hash-table->alist all-steps-dat))
			    ;; if logpro-used read in the stepname.dat file
			    (if (and logpro-used (common:file-exists? (conc stepname ".dat")))
				(launch:load-logpro-dat run-id test-id stepname))

                          (file-write status-file (conc stepname " " (launch:einf-exit-code exit-info) "\n"))

			    (if (steprun-good? logpro-used (launch:einf-exit-code exit-info) stepparms)
				(if (not (null? tal))
				    (loop (car tal) (cdr tal) stepname))
				(debug:print 0 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping")))
			(debug:print 0 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))
                        (file-close status-file)
                        )

                        ))))))

(define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)
  (let* ((update-period (string->number (or (configf:lookup *configdat* "setup" "test-stats-update-period") "30")))
         (start-seconds (current-seconds))
	 (calc-minutes  (lambda ()
			  (inexact->exact 
			   (round 
			    (- 
			     (current-seconds) 
			     start-seconds)))))
	 (kill-tries 0))
    ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area)
    ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area)
    (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10 update-db: #t)

    (let loop ((minutes   (calc-minutes))
	       (cpu-load  (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f)))
	       (disk-free (get-df (current-directory)))
               (last-sync (current-seconds)))
      ;; (common:telemetry-log "zombie" (conc "launch:monitor-job - top of loop encountered at "(current-seconds)" with last-sync="last-sync))
      ;; top of loop encountered at "(current-seconds)" with
      ;; last-sync="last-sync))
      (let* ((over-time     (> (current-seconds) (+ last-sync update-period)))
             (new-cpu-load  (let* ((load  (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f)))
                                   (delta (abs (- load cpu-load))))
                              (if (> delta 0.1) ;; don't bother updating with small changes
                                  load
                                  #f)))
             (new-disk-free (let* ((df    (if over-time ;; only get df every 30 seconds
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
         ((test-get-kill-request run-id test-id)
          (set! kill-reason "KILLING TEST since received kill request (KILLREQ)")
          (set! kill-job? #t))
         ((and runtlim (> (- (current-seconds) start-seconds) runtlim))
          (set! kill-reason (conc "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" (- (current-seconds) start-seconds) " seconds, limit=" runtlim))
          (set! kill-job? #t))
         ((equal? status "DEAD")
          (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f)
          (rmt:set-state-status-and-roll-up-items run-id test-id 'foo "RUNNING" "n/a" "was marked dead; really still running.")
          ;;(set! kill-reason "KILLING TEST because it was marked as DEAD by launch:handle-zombie-tests (might indicate really overloaded server or else overzealous setup.deadtime)") ;; MARK RUNNING
          (set! kill-job? #f)))

        (debug:print 4 *default-log-port* "cpu: " new-cpu-load " disk: " new-disk-free " last-sync: " last-sync " do-sync: " do-sync)
        (launch:handle-zombie-tests run-id)
        (when do-sync
          ;;(with-output-to-file (conc (getenv "MT_TEST_RUN_DIR") "/last-loadinfo.log" #:append)
          ;;  (lambda () (pp (list (current-seconds) new-cpu-load new-disk-free (calc-minutes)))))
          ;; (common:telemetry-log "zombie" (conc  "launch:monitor-job - dosync started at "(current-seconds)))
          (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f)
          ;; (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync finished at "(current-seconds)))
	  )
        
	(if kill-job? 
	    (begin
              (debug:print-info 0 *default-log-port* "proceeding to kill test: "kill-reason)
	      (mutex-lock! m)
	      ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this
	      ;;       section and the runit section? Or add a loop that tries three times with a 1/4 second
	      ;;       between tries?







|






|
<
<
<
|
<

<







257
258
259
260
261
262
263
264
265
266
267
268
269
270
271



272

273

274
275
276
277
278
279
280
         ((test-get-kill-request run-id test-id)
          (set! kill-reason "KILLING TEST since received kill request (KILLREQ)")
          (set! kill-job? #t))
         ((and runtlim (> (- (current-seconds) start-seconds) runtlim))
          (set! kill-reason (conc "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" (- (current-seconds) start-seconds) " seconds, limit=" runtlim))
          (set! kill-job? #t))
         ((equal? status "DEAD")
          (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f update-db: #t)
          (rmt:set-state-status-and-roll-up-items run-id test-id 'foo "RUNNING" "n/a" "was marked dead; really still running.")
          ;;(set! kill-reason "KILLING TEST because it was marked as DEAD by launch:handle-zombie-tests (might indicate really overloaded server or else overzealous setup.deadtime)") ;; MARK RUNNING
          (set! kill-job? #f)))

        (debug:print 4 *default-log-port* "cpu: " new-cpu-load " disk: " new-disk-free " last-sync: " last-sync " do-sync: " do-sync)
        (launch:handle-zombie-tests run-id)
        (if do-sync ;; save meta data about the running of this test



	    (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f))

	  )

	(if kill-job? 
	    (begin
              (debug:print-info 0 *default-log-port* "proceeding to kill test: "kill-reason)
	      (mutex-lock! m)
	      ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this
	      ;;       section and the runit section? Or add a loop that tries three times with a 1/4 second
	      ;;       between tries?
322
323
324
325
326
327
328
329



330
331
332
333
334
335
336
	    (begin
	      (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses
	      (if (hash-table-ref/default misc-flags 'keep-going #f)  ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta
		  (loop (calc-minutes)
                        (or new-cpu-load cpu-load)
                        (or new-disk-free disk-free)
                        (if do-sync (current-seconds) last-sync)))))))
    (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional





(define (launch:execute encoded-cmd)
  (let* ((cmdinfo    (common:read-encoded-string encoded-cmd))
	 (tconfigreg #f))
    (setenv "MT_CMDINFO" encoded-cmd)
    ;;(bb-check-path msg: "launch:execute incoming")







|
>
>
>







323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
	    (begin
	      (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses
	      (if (hash-table-ref/default misc-flags 'keep-going #f)  ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta
		  (loop (calc-minutes)
                        (or new-cpu-load cpu-load)
                        (or new-disk-free disk-free)
                        (if do-sync (current-seconds) last-sync)))))))
    (tests:update-central-meta-info run-id test-id 
       (get-cpu-load)
       (get-df (current-directory))
       (calc-minutes) #f #f update-db: #t)) ;; NOTE: Checking twice for keep-going is intentional


(define (launch:execute encoded-cmd)
  (let* ((cmdinfo    (common:read-encoded-string encoded-cmd))
	 (tconfigreg #f))
    (setenv "MT_CMDINFO" encoded-cmd)
    ;;(bb-check-path msg: "launch:execute incoming")
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
                                                    (debug:print 0 *default-log-port* "INFO: missing files from " work-area ": " (string-intersperse bad-files ", "))
                                                    (launch:test-copy testpath work-area))))
                                            ;; one more time, change to the work-area directory
                                            (change-directory work-area)))
	       ) ;; let*

	  (if contour (setenv "MT_CONTOUR" contour))
	  
	  ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ...
	  ;;
	  (setenv "MT_TESTSUITENAME" areaname)
	  (setenv "MT_RUN_AREA_HOME" top-path)
	  (set! *toppath* top-path)
          (change-directory *toppath*) ;; temporarily switch to the run area home
	  (setenv "MT_TEST_RUN_DIR"  work-area)







<







412
413
414
415
416
417
418

419
420
421
422
423
424
425
                                                    (debug:print 0 *default-log-port* "INFO: missing files from " work-area ": " (string-intersperse bad-files ", "))
                                                    (launch:test-copy testpath work-area))))
                                            ;; one more time, change to the work-area directory
                                            (change-directory work-area)))
	       ) ;; let*

	  (if contour (setenv "MT_CONTOUR" contour))

	  ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ...
	  ;;
	  (setenv "MT_TESTSUITENAME" areaname)
	  (setenv "MT_RUN_AREA_HOME" top-path)
	  (set! *toppath* top-path)
          (change-directory *toppath*) ;; temporarily switch to the run area home
	  (setenv "MT_TEST_RUN_DIR"  work-area)
475
476
477
478
479
480
481



482
483
484
485
486
487
488
				(db:test-get-host        test-info)
				(begin
				  (debug:print 0 *default-log-port* "ERROR: failed to find a record for test-id " test-id ", exiting.")
				  (exit))))
		 (test-pid  (db:test-get-process_id  test-info)))
	    (cond
             ;; -mrw- I'm removing KILLREQ from this list so that a test in KILLREQ state is treated as a "do not run" flag.



	     ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
	      (debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request")
	      ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")

              (rmt:general-call 'set-test-start-time #f test-id)
              (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
	      ) ;; prime it for running







>
>
>







478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
				(db:test-get-host        test-info)
				(begin
				  (debug:print 0 *default-log-port* "ERROR: failed to find a record for test-id " test-id ", exiting.")
				  (exit))))
		 (test-pid  (db:test-get-process_id  test-info)))
	    (cond
             ;; -mrw- I'm removing KILLREQ from this list so that a test in KILLREQ state is treated as a "do not run" flag.
	     ;;((or (member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
	     ;;	  (and (equal? (db:test-get-state test-info) "COMPLETED")                           ;; completed/abort => rerun if asked
	     ;;	       (member (db:test-get-status test-info) '("ABORT"))))
	     ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
	      (debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request")
	      ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")

              (rmt:general-call 'set-test-start-time #f test-id)
              (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
	      ) ;; prime it for running
807
808
809
810
811
812
813


814
815
816
817
818
819
820
821
			       	(debug:print 0 *default-log-port* "test " test-name "/" item-path " not completed")
              (if (not (null? tal))
		  (loop (car tal) (cdr tal)))))))))))

;; replaced below with version that does not ssh if checking on localhost
#;(define (launch:is-test-alive host pid)
  (if (and host pid (not (equal? host "n/a")))


      (let* ((cmd (conc "ssh " host " pstree -A " pid))
	     (output (with-input-from-pipe cmd read-lines)))
	(debug:print 2 *default-log-port* "Running " cmd " received " output)
	(if (eq? (length output) 0)
	   #f
	   #t))
      #t))








>
>
|







813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
			       	(debug:print 0 *default-log-port* "test " test-name "/" item-path " not completed")
              (if (not (null? tal))
		  (loop (car tal) (cdr tal)))))))))))

;; replaced below with version that does not ssh if checking on localhost
#;(define (launch:is-test-alive host pid)
  (if (and host pid (not (equal? host "n/a")))
      (let* ((is-local (equal? host (get-host-name)))
	     (ssh-cmd   (if is-local " " (conc "ssh " host " ")))
	     (cmd (conc ssh-cmd "pstree -A " pid))
	     (output (with-input-from-pipe cmd read-lines)))
	(debug:print 2 *default-log-port* "Running " cmd " received " output)
	(if (eq? (length output) 0)
	   #f
	   #t))
      #t))

1417
1418
1419
1420
1421
1422
1423
1424





1425



1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450



1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469







1470
1471
1472
1473
1474
1475
1476
           (else #f))))
    (when do-scan?
      (debug:print 1 *default-log-port* "INFO: search and mark zombie tests")
      (rmt:set-var key (current-seconds))
      (rmt:find-and-mark-incomplete run-id #f))))













;; 1. look though disks list for disk with most space
;; 2. create run dir on disk, path name is meaningful
;; 3. create link from run dir to megatest runs area 
;; 4. remotely run the test on allocated host
;;    - could be ssh to host from hosts table (update regularly with load)
;;    - could be netbatch
;;      (launch-test db (cadr status) test-conf))
(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params)
  (mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex
  (let* ( ;; (lock-key        (conc "test-" test-id))
	;; (got-lock        (let loop ((lock        (rmt:no-sync-get-lock lock-key))
	;; 			     (expire-time (+ (current-seconds) 15))) ;; give up on getting the lock and steal it after 15 seconds
	;; 		    (if (car lock)
	;; 			#t
	;; 			(if (> (current-seconds) expire-time)
	;; 			    (begin
	;; 			      (debug:print-info 0 *default-log-port* "Timed out waiting for a lock to launch test " keyvals " " runname " " test-name " " test-path)
	;; 			      (rmt:no-sync-del! lock-key) ;; destroy the lock
	;; 			      (loop (rmt:no-sync-get-lock lock-key) expire-time)) ;; 
	;; 			    (begin
	;; 			      (thread-sleep! 1)
	;; 			      (loop (rmt:no-sync-get-lock lock-key) expire-time))))))
	 (item-path       (item-list->path itemdat))
	 (contour         #f)) ;; NOT READY FOR THIS (args:get-arg "-contour")))



    (let loop ((delta        (- (current-seconds) *last-launch*))
	       (launch-delay (configf:lookup-number *configdat* "setup" "launch-delay" default: 0)))
      (if (> launch-delay delta)
	  (begin
	    (if (common:low-noise-print 1200 "test launch delay") ;; every two hours or so remind the user about launch delay.
		(debug:print-info 0 *default-log-port* "NOTE: test launches are delayed by " launch-delay " seconds. See megatest.config launch-delay setting to adjust.")) ;; launch of " test-name " for " (- launch-delay delta) " seconds"))
	    (thread-sleep! (- launch-delay delta))
	    (loop (- (current-seconds) *last-launch*) launch-delay))))
    (change-directory *toppath*)
    (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute", *maybe* - the longer they are set the longer each launch takes (must be non-overlapping with the vars)
     (append
      (list
       (list "MT_RUN_AREA_HOME" *toppath*)
       (list "MT_TEST_NAME" test-name)
       (list "MT_RUNNAME"   runname)
       (list "MT_ITEMPATH"  item-path)
       (list "MT_CONTOUR"   contour)
       )
      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 (configf:lookup *configdat* "jobtools"     "useshell")))







|
>
>
>
>
>

>
>
>










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

|
>
>
>









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







1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452












1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466

1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
           (else #f))))
    (when do-scan?
      (debug:print 1 *default-log-port* "INFO: search and mark zombie tests")
      (rmt:set-var key (current-seconds))
      (rmt:find-and-mark-incomplete run-id #f))))


(defstruct launch:ajt
  (vars '())
  (exekey #f)
  (host-type #f)
  (test-sig  #f)
  (cmdline   #f))

;; append vars
(define (launch:ajt-add-vars dat vars)
  (launch:ajt-vars-set! dat (append (launch:ajt-vars dat) vars)))

;; 1. look though disks list for disk with most space
;; 2. create run dir on disk, path name is meaningful
;; 3. create link from run dir to megatest runs area 
;; 4. remotely run the test on allocated host
;;    - could be ssh to host from hosts table (update regularly with load)
;;    - could be netbatch
;;      (launch-test db (cadr status) test-conf))
(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params)
  (mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex
  (let* (;; locking code removed from here commented out and pasted at end of file












	 (item-path       (item-list->path itemdat))
	 (contour         #f)                         ;; NOT READY FOR THIS (args:get-arg "-contour")))
	 ;; launcher-mode will be 'adjutant or 'normal
	 (launcher-mode   (string->symbol (or (configf:lookup *configdat* "jobtools" "mode") "normal")))
	 (ajtdat          (make-launch:ajt)))
    (let loop ((delta        (- (current-seconds) *last-launch*))
	       (launch-delay (configf:lookup-number *configdat* "setup" "launch-delay" default: 0)))
      (if (> launch-delay delta)
	  (begin
	    (if (common:low-noise-print 1200 "test launch delay") ;; every two hours or so remind the user about launch delay.
		(debug:print-info 0 *default-log-port* "NOTE: test launches are delayed by " launch-delay " seconds. See megatest.config launch-delay setting to adjust.")) ;; launch of " test-name " for " (- launch-delay delta) " seconds"))
	    (thread-sleep! (- launch-delay delta))
	    (loop (- (current-seconds) *last-launch*) launch-delay))))
    (change-directory *toppath*)

    (let ((var-list (append
		     (list
		      (list "MT_RUN_AREA_HOME" *toppath*)
		      (list "MT_TEST_NAME" test-name)
		      (list "MT_RUNNAME"   runname)
		      (list "MT_ITEMPATH"  item-path)
		      (list "MT_CONTOUR"   contour)
		      )
		     itemdat)))
       ;; consolidate this code with the code in megatest.scm for
       ;; "-execute", *maybe* - the longer they are set the longer
       ;; each launch takes (must be non-overlapping with the vars)
      (alist->env-vars var-list)
      ;; the var-list into the ajtdat adjutant record whether it is needed or not.
      (launch:ajt-add-vars ajtdat var-list))
    
    (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 (configf:lookup *configdat* "jobtools"     "useshell")))
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498

1499
1500
1501
1502
1503
1504
1505


1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519









1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
	   (subrun          (> (length (hash-table-ref/default tconfig "subrun"  '())) 0)) ;; send a flag to process a subrun
	   ;; (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  (common:find-local-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)) ;; (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)
	   (testinfo   (rmt:get-test-info-by-id run-id test-id))
	   (mt_target  (string-intersperse (map cadr keyvals) "/"))
	   (debug-param (append (if (args:get-arg "-debug")  (list "-debug" (args:get-arg "-debug")) '())
				(if (args:get-arg "-logging")(list "-logging") '())
				(if (configf:lookup *configdat* "misc" "profilesw")
				    (list (configf:lookup *configdat* "misc" "profilesw"))
				    '()))))









      ;; (if hosts (set! hosts (string-split hosts)))
      ;; set the megatest to be called on the remote host
      (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest"))
      (set! mt-bindir-path (pathname-directory remote-megatest))
      (if launcher (set! launcher (string-split launcher)))
      ;; set up the run work area for this test
      (if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run
	       (not (member (db:test-get-rundir testinfo)(list "n/a" "/tmp/badname")))) ;; n/a is a placeholder and thus not a read dir
	  (begin
	    (debug:print-info 0 *default-log-port* "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path)
	    (runs:remove-test-directory testinfo 'remove-data-only))) ;; remove data only, do not perturb the record
      







<
<
<
<

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













>
>
>
>
>
>
>
>
>




|







1497
1498
1499
1500
1501
1502
1503




1504



1505
1506
1507





1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
	   (subrun          (> (length (hash-table-ref/default tconfig "subrun"  '())) 0)) ;; send a flag to process a subrun
	   ;; (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")))




	   (local-megatest  (common:find-local-megatest))



	   (launcher        (let ((l (common:get-launcher *configdat* test-name item-path launcher-mode)))
			      (if (string? l)
				  (string-split l)





				  l))) ;; some nonhomogenuity here. '(cmd param1 param2 ...) OR '(host-type launcher)
	    ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path
	   (test-sig        (conc (common:get-testsuite-name) ":" test-name ":" 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)
	   (testinfo   (rmt:get-test-info-by-id run-id test-id))
	   (mt_target  (string-intersperse (map cadr keyvals) "/"))
	   (debug-param (append (if (args:get-arg "-debug")  (list "-debug" (args:get-arg "-debug")) '())
				(if (args:get-arg "-logging")(list "-logging") '())
				(if (configf:lookup *configdat* "misc" "profilesw")
				    (list (configf:lookup *configdat* "misc" "profilesw"))
				    '()))))
      ;; save the test-sig in the ajtdat record
      (launch:ajt-test-sig-set! ajtdat test-sig)
      ;; go ahead and figure out if we have a host-type from the
      ;; launcher call above and save it in the ajtdat record
      (if (and (eq? launcher-mode 'adjutant)
	       (list? launcher)
	       (> (length launcher) 1))
	  (launch:ajt-host-type-set! ajtdat (car launcher)))
 
      ;; (if hosts (set! hosts (string-split hosts)))
      ;; set the megatest to be called on the remote host
      (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest"))
      (set! mt-bindir-path (pathname-directory remote-megatest))
      ;; (if launcher (set! launcher (string-split launcher)))           ;; yuk!
      ;; set up the run work area for this test
      (if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run
	       (not (member (db:test-get-rundir testinfo)(list "n/a" "/tmp/badname")))) ;; n/a is a placeholder and thus not a read dir
	  (begin
	    (debug:print-info 0 *default-log-port* "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path)
	    (runs:remove-test-directory testinfo 'remove-data-only))) ;; remove data only, do not perturb the record
      
1577
1578
1579
1580
1581
1582
1583



1584
1585
1586
1587
1588
1589
1590

1591
1592
1593

1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616


1617
1618
1619
1620
1621



1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
























1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
					(list 'runtlim   (if run-time-limit (common:hms-string->seconds run-time-limit) #f))
					(list 'env-ovrd  (hash-table-ref/default *configdat* "env-override" '())) 
					(list 'set-vars  (if params (hash-table-ref/default params "-setvars" #f)))
					(list 'runname   runname)
					(list 'mt-bindir-path mt-bindir-path))))))))

        (setenv "MT_CMDINFO" cmdparms)  ;; setting this for use in nblauncher



      
      ;; clean out step records from previous run if they exist
      ;; (rmt:delete-test-step-records run-id test-id)
      ;; if the dir does not exist we may have a itempath where individual variables are a path, launch anyway
      (if (common:file-exists? work-area)
	  (change-directory work-area)) ;; so that log files from the launch process don't clutter the test dir
      (cond

       ;; ((and launcher hosts) ;; must be using ssh hostname
       ;;    (set! fullcmd (append launcher (car hosts)(list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param)))
       ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms))))

       (launcher
	(set! fullcmd (append launcher (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param)))
       ;; (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms))))
       (else
	(if (not useshell)(debug:print 0 *default-log-port* "WARNING: internal launching will not work well without \"useshell yes\" in your [jobtools] section"))
	(set! fullcmd (append (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param (list (if useshell "&" ""))))))
      ;; (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if useshell "&" "")))))
      (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm"))))
      (debug:print 1 *default-log-port* "Launching " work-area)
      ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done
      (debug:print 4 *default-log-port* "fullcmd: " fullcmd)
      (set! *last-launch* (current-seconds)) ;; all that junk above takes time, set this as late as possible.
      (let* ((commonprevvals (alist->env-vars
			      (hash-table-ref/default *configdat* "env-override" '())))
	     (miscprevvals   (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute"
			      (append (list (list "MT_TEST_RUN_DIR" work-area)
					    (list "MT_TEST_NAME" test-name)
					    (list "MT_ITEM_INFO" (conc itemdat)) 
					    (list "MT_RUNNAME"   runname)
					    (list "MT_TARGET"    mt_target)
					    (list "MT_ITEMPATH"  item-path)
					    )
				      itemdat)))


	     (testprevvals   (alist->env-vars
			      (hash-table-ref/default tconfig "pre-launch-env-overrides" '())))
	     ;; Launchwait defaults to true, must override it to turn off wait
	     (launchwait     (if (equal? (configf:lookup *configdat* "setup" "launchwait") "no") #f #t))
	     (launch-results-prev (apply (if launchwait ;; BB: TODO: refactor this to examine return code of launcher, if nonzero, set state to launch failed.



					     process:cmd-run-with-stderr-and-exitcode->list
					     process-run)
					 (if useshell
					     (let ((cmdstr (string-intersperse fullcmd " ")))
					       (if launchwait
						   cmdstr
						   (conc cmdstr " >> mt_launch.log 2>&1 &")))
					     (car fullcmd))
					 (if useshell
					     '()
					     (cdr fullcmd))))
             (success        (if launchwait (equal? 0 (cadr launch-results-prev)) #t))
             (launch-results (if launchwait (car launch-results-prev) launch-results-prev)))
























        (if (not success)
            (tests:test-set-status! run-id test-id "COMPLETED" "DEAD" "launcher failed; exited non-zero; check mt_launch.log" #f)) ;; (if launch-results launch-results "FAILED"))
        (mutex-unlock! *launch-setup-mutex*) ;; yes, really should mutex all the way to here. Need to put this entire process into a fork.
	;; (rmt:no-sync-del! lock-key)         ;; release the lock for starting this test
	(if (not launchwait) ;; give the OS a little time to allow the process to start
	    (thread-sleep! 0.01))
	(with-output-to-file "mt_launch.log"
	  (lambda ()
	    (print "LAUNCHCMD: " (string-intersperse fullcmd " "))
	    (if (list? launch-results)







>
>
>






|
>
|
|
<
>


<



|





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


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


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

<







1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609

1610
1611
1612

1613
1614
1615
1616
1617
1618
1619
1620
1621

1622
1623
1624
1625
1626
1627
1628
1629

1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679

1680
1681
1682
1683
1684
1685
1686
					(list 'runtlim   (if run-time-limit (common:hms-string->seconds run-time-limit) #f))
					(list 'env-ovrd  (hash-table-ref/default *configdat* "env-override" '())) 
					(list 'set-vars  (if params (hash-table-ref/default params "-setvars" #f)))
					(list 'runname   runname)
					(list 'mt-bindir-path mt-bindir-path))))))))

        (setenv "MT_CMDINFO" cmdparms)  ;; setting this for use in nblauncher
        
      ;; save the cmdparms in the ajtdat
      (launch:ajt-exekey-set! ajtdat cmdparms)
      
      ;; clean out step records from previous run if they exist
      ;; (rmt:delete-test-step-records run-id test-id)
      ;; if the dir does not exist we may have a itempath where individual variables are a path, launch anyway
      (if (common:file-exists? work-area)
	  (change-directory work-area)) ;; so that log files from the launch process don't clutter the test dir

      ;; save the command line for adjutant mode (might never be needed but best to assemble it here)
      (launch:ajt-cmdline-set! ajtdat (string-intersperse
				       (append (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param)))

      (cond       
       (launcher
	(set! fullcmd (append launcher (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param)))

       (else
	(if (not useshell)(debug:print 0 *default-log-port* "WARNING: internal launching will not work well without \"useshell yes\" in your [jobtools] section"))
	(set! fullcmd (append (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param (list (if useshell "&" ""))))))
      
      (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm"))))
      (debug:print 1 *default-log-port* "Launching " work-area)
      ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done
      (debug:print 4 *default-log-port* "fullcmd: " fullcmd)
      (set! *last-launch* (current-seconds)) ;; all that junk above takes time, set this as late as possible.

      (let* ((env-override-vars  (hash-table-ref/default *configdat* "env-override" '()))
	     (commonprevvals     (alist->env-vars env-override-vars))
	     (misc-vars          (append (list (list "MT_TEST_RUN_DIR" work-area)
					       (list "MT_TEST_NAME" test-name)
					       (list "MT_ITEM_INFO" (conc itemdat)) 
					       (list "MT_RUNNAME"   runname)
					       (list "MT_TARGET"    mt_target)
					       (list "MT_ITEMPATH"  item-path))

					 itemdat))
	     (miscprevvals   (alist->env-vars misc-vars));; consolidate this code with the code in megatest.scm for "-execute"
	     (test-vars      (hash-table-ref/default tconfig "pre-launch-env-overrides" '()))
	     (testprevvals   (alist->env-vars test-vars))
			      
	     ;; Launchwait defaults to true, must override it to turn off wait
	     (launchwait     (if (equal? (configf:lookup *configdat* "setup" "launchwait") "no") #f #t))
	     ;; BB: TODO: refactor this to examine return code of launcher, if nonzero, set state to launch failed.
	     (launch-results-prev (if (eq? launcher-mode 'adjutant)
				      '(#t 0) ;; just some fake data to fool downstream but non-applicable code
				      (apply (if launchwait
						 process:cmd-run-with-stderr-and-exitcode->list
						 process-run)
					     (if useshell
						 (let ((cmdstr (string-intersperse fullcmd " ")))
						   (if launchwait
						       cmdstr
						       (conc cmdstr " >> mt_launch.log 2>&1 &")))
						 (car fullcmd))
					     (if useshell
						 '()
						 (cdr fullcmd)))))
             (success        (if launchwait (equal? 0 (cadr launch-results-prev)) #t))
             (launch-results (if launchwait (car launch-results-prev) launch-results-prev)))

	(launch:ajt-add-vars ajtdat env-override-vars)
	(launch:ajt-add-vars ajtdat misc-vars)
	(launch:ajt-add-vars ajtdat test-vars)

	;; if in adjutant mode we register the job in the jobs_queue
	;; then fire off an adjutant runner
	;;
	(if (eq? launcher-mode 'adjutant)
	    (let* ((adjutant-runner-cmd (append (cdr launcher)
						(list remote-megatest "-adjutant"
						      (launch:ajt-host-type ajtdat)
						      "-start-dir" *toppath*)))
		   (adj-cmd     (conc (string-intersperse (map conc adjutant-runner-cmd) " ")
				      "&")))         
	      (rmt:no-sync-add-job
	       (launch:ajt-host-type  ajtdat)
	       (launch:ajt-vars ajtdat)
	       (launch:ajt-exekey     ajtdat)
	       (launch:ajt-cmdline    ajtdat))
	      (print "adj-cmd: " adj-cmd)
	      (system adj-cmd)
	      ))
	
	(if (not success)
            (tests:test-set-status! run-id test-id "COMPLETED" "DEAD" "launcher failed; exited non-zero; check mt_launch.log" #f)) ;; (if launch-results launch-results "FAILED"))

	;; (rmt:no-sync-del! lock-key)         ;; release the lock for starting this test
	(if (not launchwait) ;; give the OS a little time to allow the process to start
	    (thread-sleep! 0.01))
	(with-output-to-file "mt_launch.log"
	  (lambda ()
	    (print "LAUNCHCMD: " (string-intersperse fullcmd " "))
	    (if (list? launch-results)
1656
1657
1658
1659
1660
1661
1662




1663
1664
1665
1666
1667
1668
1669
	      ;; but this hack will work! Thanks go to Alan Post of the Chicken email list
	      ;; NB// Is this still needed? Should be safe to go back to "exit" now?
	      (process-signal (current-process-id) signal/kill)
	      ))
	(alist->env-vars miscprevvals)
	(alist->env-vars testprevvals)
	(alist->env-vars commonprevvals)




	launch-results))
    (change-directory *toppath*)
    (thread-sleep! (configf:lookup-number *configdat* "setup" "inter-test-delay" default: 0.0))))

;; recover a test where the top controlling mtest may have died
;;
(define (launch:recover-test run-id test-id)







>
>
>
>







1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
	      ;; but this hack will work! Thanks go to Alan Post of the Chicken email list
	      ;; NB// Is this still needed? Should be safe to go back to "exit" now?
	      (process-signal (current-process-id) signal/kill)
	      ))
	(alist->env-vars miscprevvals)
	(alist->env-vars testprevvals)
	(alist->env-vars commonprevvals)
	;; yes, really should mutex all the way to here. Need to put this entire process into a fork.
	;; the unlock previously was further up. This seemed wrong as we should not proceed until the
	;; vars have been reset.
	(mutex-unlock! *launch-setup-mutex*)
	launch-results))
    (change-directory *toppath*)
    (thread-sleep! (configf:lookup-number *configdat* "setup" "inter-test-delay" default: 0.0))))

;; recover a test where the top controlling mtest may have died
;;
(define (launch:recover-test run-id test-id)
1685
1686
1687
1688
1689
1690
1691
















		     (read-symbolic-link (conc "/proc/" pid "/cwd"))
		     #f)))
    ;; now wait on that process if all is correct
    ;; periodically update the db with runtime
    ;; when the process exits look at the db, if still RUNNING after 10 seconds set
    ;; state/status appropriately
    (process-wait pid)))























>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
		     (read-symbolic-link (conc "/proc/" pid "/cwd"))
		     #f)))
    ;; now wait on that process if all is correct
    ;; periodically update the db with runtime
    ;; when the process exits look at the db, if still RUNNING after 10 seconds set
    ;; state/status appropriately
    (process-wait pid)))


 ;; (lock-key        (conc "test-" test-id))
	;; (got-lock        (let loop ((lock        (rmt:no-sync-get-lock lock-key))
	;; 			     (expire-time (+ (current-seconds) 15))) ;; give up on getting the lock and steal it after 15 seconds
	;; 		    (if (car lock)
	;; 			#t
	;; 			(if (> (current-seconds) expire-time)
	;; 			    (begin
	;; 			      (debug:print-info 0 *default-log-port* "Timed out waiting for a lock to launch test " keyvals " " runname " " test-name " " test-path)
	;; 			      (rmt:no-sync-del! lock-key) ;; destroy the lock
	;; 			      (loop (rmt:no-sync-get-lock lock-key) expire-time)) ;; 
	;; 			    (begin
	;; 			      (thread-sleep! 1)
	;; 			      (loop (rmt:no-sync-get-lock lock-key) expire-time))))))
	 

Modified megatest.scm from [35ed864745] to [dab1c0eb1d].

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

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

(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")
(include "megatest-fossil-hash.scm")

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
     readline apropos json http-client directory-utils typed-records
     http-client srfi-18 extras format)

;; Added for csv stuff - will be removed
;;
(use sparse-vectors)



(require-library mutils)

(define *usage-log-file* #f)    ;; put path to file for logging usage in this var in the ~/.megatestrc file
(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file

;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
;;
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))







>
>
>
>
>
>
>












|
|





>
>
|







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

(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 mutils))
(declare (uses adjutant))
(import adjutant)

(declare (uses mttop))
(import mttop)

;; (declare (uses ftail))
;; (import ftail)

(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")
(include "megatest-fossil-hash.scm")

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
     readline apropos json http-client directory-utils typed-records matchable
     http-client srfi-18 extras format call-with-environment-variables)

;; Added for csv stuff - will be removed
;;
(use sparse-vectors)

(import mutils)

;;(require-library mutils)

(define *usage-log-file* #f)    ;; put path to file for logging usage in this var in the ~/.megatestrc file
(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file

;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
;;
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
100
101
102
103
104
105
106

107
108
109
110
111
112
113
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2017
 
Usage: megatest [options]
  -h                      : this help
  -manual                 : show the Megatest user manual
  -version                : print megatest version (currently " megatest-version ")


Launching and managing runs
  -run                    : run all tests or as specified by -testpatt
  -remove-runs            : remove the data for a run, requires -runname and -testpatt
                            Optionally use :state and :status, use -keep-records to remove only
                            the run data. Use -kill-wait to override the 10 second
                            per test wait after kill delay (e.g. -kill-wait 0). 







>







109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2017
 
Usage: megatest [options]
  -h                      : this help
  -manual                 : show the Megatest user manual
  -version                : print megatest version (currently " megatest-version ")
  help                    : help for the new Megatest interface

Launching and managing runs
  -run                    : run all tests or as specified by -testpatt
  -remove-runs            : remove the data for a run, requires -runname and -testpatt
                            Optionally use :state and :status, use -keep-records to remove only
                            the run data. Use -kill-wait to override the 10 second
                            per test wait after kill delay (e.g. -kill-wait 0). 
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
  -sync-to-megatest.db    : pull data from cache files in /tmp/$USER to megatest.db
  -sync-to dest           : sync to new postgresql central style database
  -update-meta            : update the tests metadata for all tests
  -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
                                 overwritten by values set in config files.
  -server -|hostname      : start the server (reduces contention on megatest.db), use
                            - to automatically figure out hostname
  -adjutant C,M           : start the server/adjutant with allocated cores C and Mem M (Gig), 
                            use 0,0 to auto use full machine
  -transport http|rpc     : use http or rpc for transport (default is http) 
  -log logfile            : send stdout and stderr to logfile
  -list-servers           : list the servers 
  -kill-servers           : kill all servers
  -repl                   : start a repl (useful for extending megatest)
  -load file.scm          : load and run file.scm







|







207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
  -sync-to-megatest.db    : pull data from cache files in /tmp/$USER to megatest.db
  -sync-to dest           : sync to new postgresql central style database
  -update-meta            : update the tests metadata for all tests
  -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
                                 overwritten by values set in config files.
  -server -|hostname      : start the server (reduces contention on megatest.db), use
                            - to automatically figure out hostname
  -adjutant host-type     : start the server/adjutant with given host-type
                            use 0,0 to auto use full machine
  -transport http|rpc     : use http or rpc for transport (default is http) 
  -log logfile            : send stdout and stderr to logfile
  -list-servers           : list the servers 
  -kill-servers           : kill all servers
  -repl                   : start a repl (useful for extending megatest)
  -load file.scm          : load and run file.scm
266
267
268
269
270
271
272




273
274
275
276
277
278
279

Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))

;;  -gui                    : start a gui interface
;;  -config fname           : override the runconfigs file with fname





;; process args
(define remargs (args:get-args 
		 (argv)
		 (list  "-runtests"  ;; run a specific test
			"-config"    ;; override the config file name
			"-append-config"
			"-execute"   ;; run the command encoded in the base64 parameter







>
>
>
>







276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293

Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))

;;  -gui                    : start a gui interface
;;  -config fname           : override the runconfigs file with fname


(mttop-run (command-line-arguments)
	   '("help"))

;; process args
(define remargs (args:get-args 
		 (argv)
		 (list  "-runtests"  ;; run a specific test
			"-config"    ;; override the config file name
			"-append-config"
			"-execute"   ;; run the command encoded in the base64 parameter
875
876
877
878
879
880
881
882



883
884
885
886
887
888
889
(let ((envcap (args:get-arg "-envcap")))
  (if envcap
      (let* ((db      (env:open-db (if (null? remargs) "envdat.db" (car remargs)))))
	(env:save-env-vars db envcap)
	(env:close-database db)
	(set! *didsomething* #t))))

;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b 



;;
(let ((envdelta (args:get-arg "-envdelta")))
  (if envdelta
      (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta)))
	(if (not (null? match))
	    (let* ((db        (env:open-db (if (null? remargs) "envdat.db" (car remargs))))
		   ;; (resctx    (cadr match))







|
>
>
>







889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
(let ((envcap (args:get-arg "-envcap")))
  (if envcap
      (let* ((db      (env:open-db (if (null? remargs) "envdat.db" (car remargs)))))
	(env:save-env-vars db envcap)
	(env:close-database db)
	(set! *didsomething* #t))))

;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b
;;
;; db file can be stuck on the end of the command line:
;;   megatest -envdelta start-end -dumpmode bash -o .ezsteps/step5.sh /tmp/myfile.db 
;;
(let ((envdelta (args:get-arg "-envdelta")))
  (if envdelta
      (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta)))
	(if (not (null? match))
	    (let* ((db        (env:open-db (if (null? remargs) "envdat.db" (car remargs))))
		   ;; (resctx    (cadr match))
916
917
918
919
920
921
922











923
924
925
926










927










928
929
930
931
932
933
934
935
;;
(if (args:get-arg "-server")
    (let ((tl        (launch:setup))
          (transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
      (server:launch 0 transport-type)
      (set! *didsomething* #t)))












;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
;; a specific Megatest area. Detail are being hashed out and this may change.
;;
(if (args:get-arg "-adjutant")










    (begin










      (adjutant-run)
      (set! *didsomething* #t)))

(if (or (args:get-arg "-list-servers")
        (args:get-arg "-kill-servers"))
    (let ((tl (launch:setup)))
      (if tl ;; all roads from here exit
	  (let* ((servers (server:get-list *toppath*))







>
>
>
>
>
>
>
>
>
>
>




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







933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
;;
(if (args:get-arg "-server")
    (let ((tl        (launch:setup))
          (transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
      (server:launch 0 transport-type)
      (set! *didsomething* #t)))


(define (naylist->alist inlst)
  (map (lambda (dat)
	 (cons (car dat)
	       (or (if (list?   (cdr dat))
		       (if (null? (cdr dat)) ""
			   (cadr dat))
		       (cdr dat))
		   ""))) ;; we need a string for call-with-environment-variables
       inlst))

;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
;; a specific Megatest area. Detail are being hashed out and this may change.
;;
(if (args:get-arg "-adjutant")
    (let* ((host-type (args:get-arg "-adjutant")))
      (launch:setup) ;; dang it, wish this wasn't needed
      (print "Running the adjutant!")
      (let loop ((wait-count 0))
	(if (< wait-count 10) ;; 6 x 10 seconds = one minute
	    (let* ((dat (rmt:no-sync-take-job host-type)))
	      (match dat
		  ((id ht vars exekey cmdline state event-time last-update)
		      (let ((vars-alist (with-input-from-string vars read)
					))
			(print "Vars:")
			(pp vars-alist)
			(call-with-environment-variables
			 (naylist->alist vars-alist)
			 (lambda ()
			   (system cmdline))))
		      (loop 0))
		  (else
		   (thread-sleep! 10)
		   (loop (+ wait-count 1)))))
	    (print "I'm bored. Exiting.")))
      ;; (adjutant-run (args:get-arg "-ajutant") rmt:no-sync-take-job)
      (set! *didsomething* #t)))

(if (or (args:get-arg "-list-servers")
        (args:get-arg "-kill-servers"))
    (let ((tl (launch:setup)))
      (if tl ;; all roads from here exit
	  (let* ((servers (server:get-list *toppath*))

Added mttop.scm version [0ba1c89f48].















































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
;; Copyright 2006-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;; This is from the perl world, a hash of hashes is a super easy way to keep a handle on
;; lots of disparate data
;;

(declare (unit mttop))

(module mttop
    *

(import chicken scheme
	;; data-structures posix
	srfi-1
	;; srfi-13
	srfi-69
	ports
	extras
	regex
	posix
	data-structures
	matchable
	)

(define (str-is-cmd cmd all-cmds)
  (let* ((rx  (regexp (conc "^" cmd ".*")))
	 (mx  (filter string? (map (lambda (x)
				     (let ((res (string-match rx x)))
				       (if res (car res) #f)))
				   all-cmds))))
    (if (eq? (length mx) 1) ;; have a command
	(car mx)
	#f)))

(define (mttop-run args all-cmds)
  ;; any path through this call must end in exit if it is NOT an old Megatest call
  (if (null? args)
      #f ;; continue on and do the old Megatest stuff
      (let ((cmd (str-is-cmd (car args) all-cmds)))
	(if cmd
	    (begin
	      (case (string->symbol cmd)
		((help)(print "New help"))
		(else (print "Command " cmd " is not implemented yet.")))
	      (exit)) ;; always exit here
	    #f))))    ;; or continue on to Megatest old stuff here
  
)

Modified rmt.scm from [ed2cbd88f2] to [d89d68077a].

54
55
56
57
58
59
60



















61
62
63
64
65
66
67


68
69
70
71
72
73
74
75
		  (client:setup areapath)
		  #f))))

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

(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id




















;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected

  #;(common:telemetry-log (conc "rmt:"(->string cmd))
                        payload: `((rid . ,rid)
                                   (params . ,params)))


                          
  (if (> attemptnum 2)
      (debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum))
    
  (cond
   ((> attemptnum 2) (thread-sleep! 0.05))
   ((> attemptnum 10) (thread-sleep! 0.5))
   ((> attemptnum 20) (thread-sleep! 1)))







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







>
>
|







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
		  (client:setup areapath)
		  #f))))

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

(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id

(define *rmt-query-last-call-time* 0)
(define *rmt-query-last-rest-time* 0) ;; last time there was at least a 1/2 second rest - giving other processes access to the db

;; NOTE: This query rest algorythm will not adapt to long query times. REDESIGN NEEDED. TODO. FIXME.
;;
(define (rmt:query-rest cmd rid params)
  (let* ((now (current-milliseconds)))
    (cond
     ((> (- now *rmt-query-last-call-time*) 100)  ;; it's been a while since last query - no need to rest
      (set! *rmt-query-last-rest-time*  now)
      (set! *rmt-query-last-call-time*  now))
     ((> (- now *rmt-query-last-rest-time*) 5000) ;; no natural rests have happened
      (debug:print 0 *default-log-port* "query rest needed. blocking for 0.1 second. cmd="cmd", run id="rid", params="params)
      (thread-sleep! 0.1) ;; force a rest of a half second
      (set! *rmt-query-last-rest-time* now)
      (set! *rmt-query-last-call-time* now))
     (else ;; sufficient rests have occurred, just record the last query time
      (set! *rmt-query-last-call-time* now)))))

;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected

  #;(common:telemetry-log (conc "rmt:"(->string cmd))
                        payload: `((rid . ,rid)
                                   (params . ,params)))
  (if (not (equal? (configf:lookup *configdat* "setup" "query-rest") "no"))
      (rmt:query-rest cmd rid params))
  
  (if (> attemptnum 2)
      (debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum))
    
  (cond
   ((> attemptnum 2) (thread-sleep! 0.05))
   ((> attemptnum 10) (thread-sleep! 0.5))
   ((> attemptnum 20) (thread-sleep! 1)))
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
				  (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
				(if (and (vector? v)
					 (> (vector-length v) 1))
				    (let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
				      newvec)           ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
				    (vector #t '()))))  ;; we could also check that the returned types are valid
			     (vector #t '())))
	 (success        (vector-ref resdat 0))
	 (res            (vector-ref resdat 1))
	 (duration       (- (current-milliseconds) start)))
    (if (and read-only qry-is-write)
        (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
    (if (not success)
	(if (> remretries 0)
	    (begin
	      (debug:print-error 0 *default-log-port* "local query failed. Trying again.")
	      (thread-sleep! (/ (random 5000) 1000)) ;; some random delay 
	      (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1)))
	    (begin
	      (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up")
	      #f))
	(begin
	  ;; (rmt:update-db-stats run-id cmd params duration)
	  ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it
	  (if qry-is-write
	      (let ((start-time (current-seconds)))
		(mutex-lock! *db-multi-sync-mutex*)
/		(set! *db-last-access* start-time)  ;; THIS IS PROBABLY USELESS? (we are on a client)
                (mutex-unlock! *db-multi-sync-mutex*)))))
    res))

(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
  (let* ((run-id   (if run-id run-id 0))
	 (res  	   (handle-exceptions
		       exn







|
|


















|







405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
				  (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
				(if (and (vector? v)
					 (> (vector-length v) 1))
				    (let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
				      newvec)           ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
				    (vector #t '()))))  ;; we could also check that the returned types are valid
			     (vector #t '())))
	 (success        (common:safe-vector-ref resdat 0 #f)) ;; (vector-ref resdat 0))
	 (res            (common:safe-vector-ref resdat 1 #f)) ;; (vector-ref resdat 1))
	 (duration       (- (current-milliseconds) start)))
    (if (and read-only qry-is-write)
        (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
    (if (not success)
	(if (> remretries 0)
	    (begin
	      (debug:print-error 0 *default-log-port* "local query failed. Trying again.")
	      (thread-sleep! (/ (random 5000) 1000)) ;; some random delay 
	      (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1)))
	    (begin
	      (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up")
	      #f))
	(begin
	  ;; (rmt:update-db-stats run-id cmd params duration)
	  ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it
	  (if qry-is-write
	      (let ((start-time (current-seconds)))
		(mutex-lock! *db-multi-sync-mutex*)
		(set! *db-last-access* start-time)  ;; THIS IS PROBABLY USELESS? (we are on a client)
                (mutex-unlock! *db-multi-sync-mutex*)))))
    res))

(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
  (let* ((run-id   (if run-id run-id 0))
	 (res  	   (handle-exceptions
		       exn
540
541
542
543
544
545
546
547
548
549
550
551

















552
553
554
555
556
557
558
;; Just some syntatic sugar
(define (rmt:register-test run-id test-name item-path)
  (rmt:general-call 'register-test run-id run-id test-name item-path))

(define (rmt:get-test-id run-id testname item-path)
  (rmt:send-receive 'get-test-id run-id (list run-id testname item-path)))

;; run-id is NOT used
;;
(define (rmt:get-test-info-by-id run-id test-id)
  (if (number? test-id)
      (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id))

















      (begin
	(debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
	(print-call-chain (current-error-port))
	#f)))

(define (rmt:test-get-rundir-from-test-id run-id test-id)
  (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))







|



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







561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
;; Just some syntatic sugar
(define (rmt:register-test run-id test-name item-path)
  (rmt:general-call 'register-test run-id run-id test-name item-path))

(define (rmt:get-test-id run-id testname item-path)
  (rmt:send-receive 'get-test-id run-id (list run-id testname item-path)))

;; run-id is NOT used - but it will be! 
;;
(define (rmt:get-test-info-by-id run-id test-id)
  (if (number? test-id)
      (let* ((testdat  (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id)))
             (trundir  (vector-ref testdat 10))
	     (trundatf (conc trundir"/.mt_data/test-run.dat")))
	;; now we can update a couple fields from the filesystem
	(handle-exceptions
	    exn
	    (begin
	      (debug:print-info 0 *default-log-port* "Could not update testdat record from "trundatf", exn=" exn)
	      #f)
	  (if (and trundir
		   (file-exists? trundatf))
	      (let* ((duration     (vector-ref testdat 12)) ;; (db:test-get-run_duration testdat))
		     (event-time   (vector-ref testdat 5))   ;; (db:test-get-event_time   testdat))
		     (last-touch   (file-modification-time trundatf))
		     (new-duration (max duration (- last-touch event-time))))
		(vector-set! testdat 12 new-duration))))
	      #;(db:test-set-run_duration! testdat (max duration (- last-touch event-time)))
	testdat)
      (begin
	(debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
	(print-call-chain (current-error-port))
	#f)))

(define (rmt:test-get-rundir-from-test-id run-id test-id)
  (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))
677
678
679
680
681
682
683

684

685
686
687
688
689
690
691
		  (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname)))
	   run-ids))))

(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f))
  (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps)))

(define (rmt:get-count-tests-running-for-run-id run-id)

  (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))


(define (rmt:get-not-completed-cnt run-id)
  (rmt:send-receive 'get-not-completed-cnt run-id (list run-id)))


;; Statistical queries








>
|
>







715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
		  (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname)))
	   run-ids))))

(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f))
  (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps)))

(define (rmt:get-count-tests-running-for-run-id run-id)
  (if (number? run-id)
      (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))
      0))

(define (rmt:get-not-completed-cnt run-id)
  (rmt:send-receive 'get-not-completed-cnt run-id (list run-id)))


;; Statistical queries

943
944
945
946
947
948
949









950
951
952
953
954
955
956
  (rmt:send-receive 'no-sync-get/default #f `(,var ,default)))

(define (rmt:no-sync-del! var)
  (rmt:send-receive 'no-sync-del! #f `(,var)))

(define (rmt:no-sync-get-lock keyname)
  (rmt:send-receive 'no-sync-get-lock #f `(,keyname)))










;;======================================================================
;; A R C H I V E S
;;======================================================================

(define (rmt:archive-get-allocations  testname itempath dneeded)
  (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded)))







>
>
>
>
>
>
>
>
>







983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
  (rmt:send-receive 'no-sync-get/default #f `(,var ,default)))

(define (rmt:no-sync-del! var)
  (rmt:send-receive 'no-sync-del! #f `(,var)))

(define (rmt:no-sync-get-lock keyname)
  (rmt:send-receive 'no-sync-get-lock #f `(,keyname)))

(define (rmt:no-sync-add-job host-type vars-list exekey cmdline)
  (rmt:send-receive 'no-sync-add-job #f `(,host-type ,vars-list ,exekey ,cmdline)))

(define (rmt:no-sync-take-job host-type)
  (rmt:send-receive 'no-sync-take-job #f `(,host-type)))

(define (rmt:no-sync-job-records-clean)
  (rmt:set-receive 'no-sync-job-records-clean #f '()))

;;======================================================================
;; A R C H I V E S
;;======================================================================

(define (rmt:archive-get-allocations  testname itempath dneeded)
  (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded)))

Modified runs.scm from [89f36cc1cb] to [fe040354c9].

59
60
61
62
63
64
65
66



























67
68
69
70
71
72
73
  (last-jobs-check-time    0)
  )

(defstruct runs:testdat
  hed tal reg reruns  test-record
  test-name item-path jobgroup
  waitons testmode  newtal itemmaps prereqs-not-met)
  



























;; look in the $MT_RUN_AREA_HOME/.softlocks directory for key-host-pid.softlock files
;;  - remove any that are over 3600 seconds old
;;  - if there are any that are younger than 10 seconds
;;      * sleep 10 seconds
;;      * touch my key-host-pid.softlock file
;;      * return
;;  - if there are no files younger than 10 seconds







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







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
  (last-jobs-check-time    0)
  )

(defstruct runs:testdat
  hed tal reg reruns  test-record
  test-name item-path jobgroup
  waitons testmode  newtal itemmaps prereqs-not-met)

(module runsmod
    (
     runs:wait-if-seen-recently
     )
  
(import scheme chicken data-structures extras files)
(import posix typed-records srfi-18 srfi-69
	  md5 message-digest
	  regex srfi-1)

(define *last-seen-ht* (make-hash-table))

(define (runs:wait-if-seen-recently wait-until . keys)
  (let* ((full-key   (string-intersperse keys "-"))
	 (last-seen  (hash-table-ref/default *last-seen-ht* full-key 0))
	 (now        (current-seconds))
	 (delta      (- now last-seen))
	 (needed     (if (< delta wait-until)
			 0
			 (- wait-until delta))))
    (if (> needed 0)(thread-sleep! needed))
    (hash-table-set! *last-seen-ht* full-key (current-seconds))
    needed))
)

(import runsmod)
    
;; look in the $MT_RUN_AREA_HOME/.softlocks directory for key-host-pid.softlock files
;;  - remove any that are over 3600 seconds old
;;  - if there are any that are younger than 10 seconds
;;      * sleep 10 seconds
;;      * touch my key-host-pid.softlock file
;;      * return
;;  - if there are no files younger than 10 seconds
490
491
492
493
494
495
496


497
498
499
500
501
502
503




;; return #t when all items in waitors-upon list are represented in test-patt, #f otherwise.
(define (runs:testpatts-mention-waitors-upon? test-patt waitors-upon)
  (null? (tests:filter-test-names-not-matched waitors-upon test-patt)))



;;======================================================================
;; runs:run-tests is called from megatest.scm and itself
;;======================================================================
;;
;;  test-names: Comma separated patterns same as test-patts but used in selection 
;;              of tests to run. The item portions are not respected.







>
>







517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532




;; return #t when all items in waitors-upon list are represented in test-patt, #f otherwise.
(define (runs:testpatts-mention-waitors-upon? test-patt waitors-upon)
  (null? (tests:filter-test-names-not-matched waitors-upon test-patt)))

(define *find-and-mark-incomplete-last-run* (make-hash-table))

;;======================================================================
;; runs:run-tests is called from megatest.scm and itself
;;======================================================================
;;
;;  test-names: Comma separated patterns same as test-patts but used in selection 
;;              of tests to run. The item portions are not respected.
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
    ;; run the run prehook if there are no tests yet run for this run:
    ;;
    (runs:run-pre-hook run-id)
    ;; mark all test launched flag as false in the meta table 
    (rmt:set-var (conc "lunch-complete-" run-id) "no")
    (debug:print-info 1 *default-log-port* "Setting end-of-run to no")
    (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
			       (if x (string->number x) #f)))
	  (config-rerun-cnt (if config-reruns
			config-reruns
			1)))
    (if (eq? config-rerun-cnt run-count)
      (rmt:set-var (conc "end-of-run-" run-id) "no")))

    (rmt:set-run-state-status run-id "new" "n/a")
    ;; now add non-directly referenced dependencies (i.e. waiton)
    ;;======================================================================
    ;; refactoring this block into tests:get-full-data
    ;;
    ;; What happended, this code is now duplicated in tests!?
    ;;







|
|
|
|
|
|
|







691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
    ;; run the run prehook if there are no tests yet run for this run:
    ;;
    (runs:run-pre-hook run-id)
    ;; mark all test launched flag as false in the meta table 
    (rmt:set-var (conc "lunch-complete-" run-id) "no")
    (debug:print-info 1 *default-log-port* "Setting end-of-run to no")
    (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
				 (if x (string->number x) #f)))
	   (config-rerun-cnt (if config-reruns
				 config-reruns
				 1)))
      (if (eq? config-rerun-cnt run-count)
	  (rmt:set-var (conc "end-of-run-" run-id) "no")))
    
    (rmt:set-run-state-status run-id "new" "n/a")
    ;; now add non-directly referenced dependencies (i.e. waiton)
    ;;======================================================================
    ;; refactoring this block into tests:get-full-data
    ;;
    ;; What happended, this code is now duplicated in tests!?
    ;;
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809





810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
	(debug:print-info 1 *default-log-port* "Adding \"" (string-intersperse required-tests " ") "\" to the run queue"))
    ;; NOTE: these are all parent tests, items are not expanded yet.
    (debug:print-info 4 *default-log-port* "test-records=" (hash-table->alist test-records))
    (let ((reglen (configf:lookup *configdat* "setup" "runqueue")))
      (if (> (length (hash-table-keys test-records)) 0)
	  (let* ((keep-going        #t)
		 (run-queue-retries 5)
		 #;(th1        (make-thread (lambda ()
					    (handle-exceptions
						exn
						(begin
						  (print-call-chain)
						  (print " message: " ((condition-property-accessor 'exn 'message) exn)))
					      (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests
								    (any->number reglen) all-tests-registry)))
					  "runs:run-tests-queue"))
		 (th2        (make-thread (lambda ()			 ;; BBQ: why are we visiting ALL runs here?	    
					    ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ...
					    (let ((run-ids (rmt:get-all-run-ids)))
					      (for-each (lambda (run-id)
							  (if keep-going
							      (handle-exceptions
							       exn
							       (debug:print 0 *default-log-port* "error in calling find-and-mark-incomplete for run-id " run-id ", exn=" exn)





							       (rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime))) ;; could be root of https://hsdes.intel.com/appstore/article/#/220546828/main -- Title: Megatest jobs show DEAD even though they are still running (1.64/27)
							run-ids)))
					  "runs: mark-incompletes")))
	    ;; (thread-start! th1)
	    (thread-start! th2)
	    ;; (thread-join! th1)
	    ;; just do the main stuff in the main thread
	    (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests
								    (any->number reglen) all-tests-registry)
	    (set! keep-going #f)
	    (thread-join! th2)
	    ;; if run-count > 0 call, set -preclean and -rerun STUCK/DEAD
	    (if (> run-count 0) ;; handle reruns
		(begin
		  (if (not (hash-table-ref/default flags "-preclean" #f))
		      (hash-table-set! flags "-preclean" #t))
		  (if (not (hash-table-ref/default flags "-rerun" #f))
		      (hash-table-set! flags "-rerun" "ABORT,STUCK/DEAD,n/a,ZERO_ITEMS"))
		  ;; recursive call to self
      (runs:run-tests target runname test-patts user flags run-count: (- run-count 1)))
                  (launch:end-of-run-check run-id)))
	  (debug:print-info 0 *default-log-port* "No tests to run")))
    (debug:print-info 4 *default-log-port* "All done by here")
    ;; TODO: try putting post hook call here
      
    ;  (debug:print-info 2 *default-log-port* " run-count " run-count)
    ;  (runs:run-post-hook run-id))
    ;  (debug:print-info 2 *default-log-port* "Not calling post hook runcount = " run-count ))   







<
<
<
<
<
<
<
<
<






|
|
>
>
>
>
>
|


<

<
<












|
|







815
816
817
818
819
820
821









822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837

838


839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
	(debug:print-info 1 *default-log-port* "Adding \"" (string-intersperse required-tests " ") "\" to the run queue"))
    ;; NOTE: these are all parent tests, items are not expanded yet.
    (debug:print-info 4 *default-log-port* "test-records=" (hash-table->alist test-records))
    (let ((reglen (configf:lookup *configdat* "setup" "runqueue")))
      (if (> (length (hash-table-keys test-records)) 0)
	  (let* ((keep-going        #t)
		 (run-queue-retries 5)









		 (th2        (make-thread (lambda ()			 ;; BBQ: why are we visiting ALL runs here?	    
					    ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ...
					    (let ((run-ids (rmt:get-all-run-ids)))
					      (for-each (lambda (run-id)
							  (if keep-going
							      (handle-exceptions
								  exn
								  (debug:print 0 *default-log-port* "error in calling find-and-mark-incomplete for run-id " run-id ", exn=" exn)
								;; lets run this only if a run has been NOT seen for more than 900 seconds
								(if (> (- (current-seconds)(hash-table-ref/default *find-and-mark-incomplete-last-run* run-id 0)) 900)
								    (begin
								      (rmt:find-and-mark-incomplete run-id #f)
								      (hash-table-set! *find-and-mark-incomplete-last-run* run-id (current-seconds)))
								    )))) ;; ovr-deadtime))) ;; could be root of https://hsdes.intel.com/appstore/article/#/220546828/main -- Title: Megatest jobs show DEAD even though they are still running (1.64/27)
							run-ids)))
					  "runs: mark-incompletes")))

	    (thread-start! th2)


	    (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests
								    (any->number reglen) all-tests-registry)
	    (set! keep-going #f)
	    (thread-join! th2)
	    ;; if run-count > 0 call, set -preclean and -rerun STUCK/DEAD
	    (if (> run-count 0) ;; handle reruns
		(begin
		  (if (not (hash-table-ref/default flags "-preclean" #f))
		      (hash-table-set! flags "-preclean" #t))
		  (if (not (hash-table-ref/default flags "-rerun" #f))
		      (hash-table-set! flags "-rerun" "ABORT,STUCK/DEAD,n/a,ZERO_ITEMS"))
		  ;; recursive call to self
		  (runs:run-tests target runname test-patts user flags run-count: (- run-count 1)))
		(launch:end-of-run-check run-id)))
	  (debug:print-info 0 *default-log-port* "No tests to run")))
    (debug:print-info 4 *default-log-port* "All done by here")
    ;; TODO: try putting post hook call here
      
    ;  (debug:print-info 2 *default-log-port* " run-count " run-count)
    ;  (runs:run-post-hook run-id))
    ;  (debug:print-info 2 *default-log-port* "Not calling post hook runcount = " run-count ))   
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
     ;; If no resources are available just kill time and loop again
     ;;
     ((not have-resources) ;; simply try again after waiting a second
      (if (runs:lownoise "no resources" 60)
	  (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ..."))
      ;; Have gone back and forth on this but db starvation is an issue.
      ;; wait one second before looking again to run jobs.
      (thread-sleep! 0.25)
      ;; could have done hed tal here but doing car/cdr of newtal to rotate tests
      (list (car newtal)(cdr newtal) reg reruns))
     
     ;; This is the final stage, everything is in place so launch the test
     ;;
     ((and have-resources
	   (or (null? prereqs-not-met)







|







1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
     ;; If no resources are available just kill time and loop again
     ;;
     ((not have-resources) ;; simply try again after waiting a second
      (if (runs:lownoise "no resources" 60)
	  (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ..."))
      ;; Have gone back and forth on this but db starvation is an issue.
      ;; wait one second before looking again to run jobs.
      (thread-sleep! 1) ;; changed back to 1 from 0.25
      ;; could have done hed tal here but doing car/cdr of newtal to rotate tests
      (list (car newtal)(cdr newtal) reg reruns))
     
     ;; This is the final stage, everything is in place so launch the test
     ;;
     ((and have-resources
	   (or (null? prereqs-not-met)
1527
1528
1529
1530
1531
1532
1533

1534
1535
1536
1537
1538
1539
1540
         (num-retries           0)
         (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
                   ;; tal: tal
                   ;; reg: reg
                   ;; reruns: reruns
                   reglen: reglen
                   regfull: #f ;; regfull







>







1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
         (num-retries           0)
         (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))
	 (misc-data             (make-hash-table)) ;; use as needed
         (runsdat (make-runs:dat
                   ;; hed: hed
                   ;; tal: tal
                   ;; reg: reg
                   ;; reruns: reruns
                   reglen: reglen
                   regfull: #f ;; regfull
1587
1588
1589
1590
1591
1592
1593






1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
      ;;
      (if (> (current-seconds)(+ last-time-incomplete 900))
          (begin
            (set! last-time-incomplete (current-seconds))
            ;; (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    (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"))
	     (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))
	     (tfullname   (db:test-make-full-name test-name item-path))
	      ;; these are hard coded item-item waits test/item-path => test/item-path2 ...
	     (extra-waits (let* ((section (configf:get-section (tests:testqueue-get-testconfig test-record) "waitons"))
				 (myextra (alist-ref tfullname section equal?)))
			    (if myextra
				(let ((extras (string-split (car myextra))))
				  (if (runs:lownoise (conc tfullname "extra-waitons" tfullname) 60)
				      (debug:print-info 0 *default-log-port* "HAVE EXTRA WAITONS for test " tfullname ": " myextra))
				  (for-each
				   (lambda (extra)
				     ;; (debug:print 0 *default-log-port* "FYI: extra = " extra " reruns = " reruns)
				     (let ((basetestname (car (string-split extra "/"))))
				       #;(if (not (member extra tal))
					   (set! reruns (append tal (list extra))))
				       (if (not (member basetestname tal))
					   (set! reruns (append tal (list basetestname))))
				       ))
				   extras)
				  extras)
				'())))
	     (waitons     (delete-duplicates (append (tests:testqueue-get-waitons test-record) extra-waits) equal?))







>
>
>
>
>
>













|











|







1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
      ;;
      (if (> (current-seconds)(+ last-time-incomplete 900))
          (begin
            (set! last-time-incomplete (current-seconds))
            ;; (rmt:find-and-mark-incomplete-all-runs)
	    ))

      ;; WAIT FOR TIME ON TIGHT LOOP
      (if (< (- (current-milliseconds)(hash-table-ref/default misc-data "tight-loop-last-time" 0))
	     100) ;; less than 1/100 second since came through the loop
	  (thread-sleep! 0.1)) ;; wait a 1/100 seconds
      (hash-table-set! misc-data "tight-loop-last-time" (current-milliseconds))
      
      ;; (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    (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"))
	     (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))
	     (tfullname   (db:test-make-full-name test-name item-path))
	     ;; these are hard coded item-item waits test/item-path => test/item-path2 ...
	     (extra-waits (let* ((section (configf:get-section (tests:testqueue-get-testconfig test-record) "waitons"))
				 (myextra (alist-ref tfullname section equal?)))
			    (if myextra
				(let ((extras (string-split (car myextra))))
				  (if (runs:lownoise (conc tfullname "extra-waitons" tfullname) 60)
				      (debug:print-info 0 *default-log-port* "HAVE EXTRA WAITONS for test " tfullname ": " myextra))
				  (for-each
				   (lambda (extra)
				     ;; (debug:print 0 *default-log-port* "FYI: extra = " extra " reruns = " reruns)
				     (let ((basetestname (car (string-split extra "/"))))
				       #;(if (not (member extra tal))
				       (set! reruns (append tal (list extra))))
				       (if (not (member basetestname tal))
					   (set! reruns (append tal (list basetestname))))
				       ))
				   extras)
				  extras)
				'())))
	     (waitons     (delete-duplicates (append (tests:testqueue-get-waitons test-record) extra-waits) equal?))
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
			   waitons:     waitons
			   testmode:    testmode
			   newtal:      newtal
			   itemmaps:    itemmaps
			   ;; prereqs-not-met: prereqs-not-met
			   )))
	(runs:dat-regfull-set! runsdat regfull)
    
	(if (> num-running 0)
            (set! last-time-some-running (current-seconds)))

        (if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000)))
            (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))
	;; (debug:print 0 *default-log-port* "max-tries-hash: " (hash-table->alist *max-tries-hash*))








|







1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
			   waitons:     waitons
			   testmode:    testmode
			   newtal:      newtal
			   itemmaps:    itemmaps
			   ;; prereqs-not-met: prereqs-not-met
			   )))
	(runs:dat-regfull-set! runsdat regfull)
	
	(if (> num-running 0)
            (set! last-time-some-running (current-seconds)))

        (if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000)))
            (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))
	;; (debug:print 0 *default-log-port* "max-tries-hash: " (hash-table->alist *max-tries-hash*))

1771
1772
1773
1774
1775
1776
1777



1778
1779
1780
1781
1782
1783
1784
				  ;; wait for load here
				  (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
				  (loop-can-run-more (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)
						     (- remtries 1)))))))
		       )))))

	  ;; I'm not clear on why prereqs are gathered here TODO: verfiy this is needed



	  (runs:testdat-prereqs-not-met-set! testdat (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))

	  ;; I'm not clear on why we'd capture running job counts here TODO: verify this is needed
	  (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs))

	  (let ((loop-list (runs:process-expanded-tests runsdat testdat))) ;; in process-expanded-tests ultimately run:test -> launch-test -> test actually running
            (if loop-list (apply loop loop-list))))







>
>
>







1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
				  ;; wait for load here
				  (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
				  (loop-can-run-more (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)
						     (- remtries 1)))))))
		       )))))

	  ;; I'm not clear on why prereqs are gathered here TODO: verfiy this is needed
	  (let ((waited (runs:wait-if-seen-recently 5 "prereqs-not-met" hed item-path))) ;; if we've been down this path in the past 5 seconds - wait out the difference
	    (if (> waited 0)(debug:print 0 *default-log-port* "Waited for prereqs-not-met-"hed"-"item-path" for " waited "seconds.")))
	  
	  (runs:testdat-prereqs-not-met-set! testdat (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))

	  ;; I'm not clear on why we'd capture running job counts here TODO: verify this is needed
	  (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs))

	  (let ((loop-list (runs:process-expanded-tests runsdat testdat))) ;; in process-expanded-tests ultimately run:test -> launch-test -> test actually running
            (if loop-list (apply loop loop-list))))
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
		  (if loop-list
		      (apply loop loop-list)
                      (debug:print-info 4 *default-log-port* " -- Can't expand hed="hed)
                      )
                  )
		;; if can't run more just loop with next possible test
		(loop (car newtal)(cdr newtal) reg reruns))))
        

	 ;; this case should not happen, added to help catch any bugs
	 ((and (list? items) itemdat)
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-5")
	  (debug:print-error 0 *default-log-port* "Should not have a list of items in a test and the itemspath set - please report this")
	  (exit 1))








|







1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
		  (if loop-list
		      (apply loop loop-list)
                      (debug:print-info 4 *default-log-port* " -- Can't expand hed="hed)
                      )
                  )
		;; if can't run more just loop with next possible test
		(loop (car newtal)(cdr newtal) reg reruns))))
         

	 ;; this case should not happen, added to help catch any bugs
	 ((and (list? items) itemdat)
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-5")
	  (debug:print-error 0 *default-log-port* "Should not have a list of items in a test and the itemspath set - please report this")
	  (exit 1))

1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907

1908
1909
1910
1911

1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
	  (loop (car reg)(cdr reg) '() reruns))
	 (else
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-9")
	  (debug:print-info 4 *default-log-port* "Exiting loop with...\n  hed=" hed "\n  tal=" tal "\n  reruns=" reruns))
	 ))) ;; end loop on sorted test names
    ;; this is the point where everything is launched and now you can mark the run in metadata table as all launched 
    (rmt:set-var (conc "lunch-complete-" run-id) "yes")  
        
    ;; now *if* -run-wait we wait for all tests to be done
    ;; Now wait for any RUNNING tests to complete (if in run-wait mode)
    ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
    (thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle
    
    (let wait-loop ((num-running      (rmt:get-count-tests-running-for-run-id run-id))
		    (prev-num-running 0))
      ;; (debug:print-info 13 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running)
      (if (and (or (args:get-arg "-run-wait")
		   (equal? (configf:lookup *configdat* "setup" "run-wait") "yes"))
	       (> num-running 0))
	  (begin
	    ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes
	    ;; (debug:print 0 *default-log-port* "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0))
	    (if (> (current-seconds)(+ last-time-incomplete 900))
		(let ((actual-num-running (rmt:get-count-tests-running-for-run-id run-id)))

		  (debug:print-info 0 *default-log-port* "Marking stuck tests as INCOMPLETE while waiting for run " run-id
				    ". Running as pid " (current-process-id) " on " (get-host-name))
		  (set! last-time-incomplete (current-seconds)) ;; FIXME, this might be causing slow down - use of set!
		  (rmt:find-and-mark-incomplete run-id #f)

		  (debug:print-info 0 *default-log-port* "run-wait specified, waiting on " actual-num-running
				    " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at "
				    (time->string (seconds->local-time (current-seconds))))))
	    ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
	    (thread-sleep! 5) ;; (if (>= num-running max-concurrent-jobs) 5 1))
	    (wait-loop (rmt:get-count-tests-running-for-run-id run-id)
		       num-running))))
    ;; LET* ((test-record
    ;; we get here on "drop through". All done!
    ;; this is moved to runs:run-testes since this function is getting called twice to ensure everthing is completed. 
    ;; (debug:print-info 0 *default-log-port* "Calling Post Hook")    
    ;; (runs:run-post-hook run-id)
    (debug:print-info 1 *default-log-port* "All tests launched")))

(define (runs:calc-fails prereqs-not-met)
  (filter (lambda (test)
	    (and (vector? test) ;; not (string? test))
		 (member (db:test-get-state test) '("INCOMPLETE" "COMPLETED")) ;; TODO: pull from *common:stuff...*
		 (not (member (db:test-get-status test)
			      '("PASS" "WARN" "WAIVED" "SKIP")))))







|














|

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







1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
	  (loop (car reg)(cdr reg) '() reruns))
	 (else
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-9")
	  (debug:print-info 4 *default-log-port* "Exiting loop with...\n  hed=" hed "\n  tal=" tal "\n  reruns=" reruns))
	 ))) ;; end loop on sorted test names
    ;; this is the point where everything is launched and now you can mark the run in metadata table as all launched 
    (rmt:set-var (conc "lunch-complete-" run-id) "yes")  
    
    ;; now *if* -run-wait we wait for all tests to be done
    ;; Now wait for any RUNNING tests to complete (if in run-wait mode)
    ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
    (thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle
    
    (let wait-loop ((num-running      (rmt:get-count-tests-running-for-run-id run-id))
		    (prev-num-running 0))
      ;; (debug:print-info 13 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running)
      (if (and (or (args:get-arg "-run-wait")
		   (equal? (configf:lookup *configdat* "setup" "run-wait") "yes"))
	       (> num-running 0))
	  (begin
	    ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes
	    ;; (debug:print 0 *default-log-port* "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0))
	    (if (> (- (current-seconds)(hash-table-ref/default *find-and-mark-incomplete-last-run* run-id 0)) 900)
		(let ((actual-num-running (rmt:get-count-tests-running-for-run-id run-id)))
		  (let ((actual-num-running num-running)) ;; (rmt:get-count-tests-running-for-run-id run-id))) ;; why call it again?
		    (debug:print-info 0 *default-log-port* "Marking stuck tests as INCOMPLETE while waiting for run " run-id
				      ". Running as pid " (current-process-id) " on " (get-host-name))
		    ;; (set! last-time-incomplete (current-seconds)) ;; FIXME, this might be causing slow down - use of set!
		    (rmt:find-and-mark-incomplete run-id #f)
		    (hash-table-set! *find-and-mark-incomplete-last-run* run-id (current-seconds))
		    (debug:print-info 0 *default-log-port* "run-wait specified, waiting on " actual-num-running
				      " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at "
				      (time->string (seconds->local-time (current-seconds)))))
		  ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
		  (thread-sleep! 5)) ;; (if (>= num-running max-concurrent-jobs) 5 1))
		(wait-loop (rmt:get-count-tests-running-for-run-id run-id)
			   num-running)))))
      ;; LET* ((test-record
      ;; we get here on "drop through". All done!
      ;; this is moved to runs:run-testes since this function is getting called twice to ensure everthing is completed. 
      ;; (debug:print-info 0 *default-log-port* "Calling Post Hook")    
      ;; (runs:run-post-hook run-id)
      (debug:print-info 1 *default-log-port* "All tests launched")))

(define (runs:calc-fails prereqs-not-met)
  (filter (lambda (test)
	    (and (vector? test) ;; not (string? test))
		 (member (db:test-get-state test) '("INCOMPLETE" "COMPLETED")) ;; TODO: pull from *common:stuff...*
		 (not (member (db:test-get-status test)
			      '("PASS" "WARN" "WAIVED" "SKIP")))))

Modified server.scm from [99d72bd3eb] to [cc03b241e1].

376
377
378
379
380
381
382

383
384
385
386
387
388
389
;; if it then has the wrong server key, wait <idle time> + 1 and call this function recursively.
;;
(define (server:wait-for-server-start-last-flag areapath)
  (let* ((start-flag (conc areapath "/logs/server-start-last"))
	 ;;; THIS INTERACTS WITH [server] timeout. Suggest using 0.1 or above for timeout (6 seconds)
	 (idletime    (configf:lookup-number *configdat* "server" "idletime" default: 4))
	 (server-key (conc (get-host-name) "-" (current-process-id))))

    (if (file-exists? start-flag)
	(let* ((fmodtime (file-modification-time start-flag))
	       (delta    (- (current-seconds) fmodtime))
	       (old-enough   (> delta idletime))
               (new-server-key "")
              )








>







376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
;; if it then has the wrong server key, wait <idle time> + 1 and call this function recursively.
;;
(define (server:wait-for-server-start-last-flag areapath)
  (let* ((start-flag (conc areapath "/logs/server-start-last"))
	 ;;; THIS INTERACTS WITH [server] timeout. Suggest using 0.1 or above for timeout (6 seconds)
	 (idletime    (configf:lookup-number *configdat* "server" "idletime" default: 4))
	 (server-key (conc (get-host-name) "-" (current-process-id))))
    ;; (thread-sleep! (/ (random 500) 1000)) ;; I don't think this made a difference
    (if (file-exists? start-flag)
	(let* ((fmodtime (file-modification-time start-flag))
	       (delta    (- (current-seconds) fmodtime))
	       (old-enough   (> delta idletime))
               (new-server-key "")
              )

Modified tasks.scm from [a73c5b318e] to [abaf4c5b40].

441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
;; remove tasks given by a string of numbers comma separated
(define (tasks:remove-queue-entries dbstruct task-ids)
  (db:with-db
   dbstruct #f #t
   (lambda (db)
     (sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");")))))

#;(define (tasks:process-queue dbstruct)
  (let* ((task   (tasks:snag-a-task dbstruct))
	 (action (if task (tasks:task-get-action task) #f)))
    (if action (print "tasks:process-queue task: " task))
    (if action
	(case (string->symbol action)
	  ((run)       (tasks:start-run     dbstruct task))
	  ((remove)    (tasks:remove-runs   dbstruct task))
	  ((lock)      (tasks:lock-runs     dbstruct task))
	  ;; ((monitor)   (tasks:start-monitor db task))
	  #;((rollup)    (tasks:rollup-runs   dbstruct task))
	  ((updatemeta)(tasks:update-meta   dbstruct task))
	  #;((kill)      (tasks:kill-monitors dbstruct task))))))

(define (tasks:tasks->text tasks)
  (let ((fmtstr "~10a~10a~10a~12a~20a~12a~12a~10a"))
    (conc (format #f fmtstr "id" "action" "owner" "state" "target" "runname" "testpatts" "params") "\n"
	  (string-intersperse 
	   (map (lambda (task)
		  (format #f fmtstr







|
|
|
|
|
|
|
|
|
|
|
|
|







441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
;; remove tasks given by a string of numbers comma separated
(define (tasks:remove-queue-entries dbstruct task-ids)
  (db:with-db
   dbstruct #f #t
   (lambda (db)
     (sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");")))))

;; (define (tasks:process-queue dbstruct)
;;   (let* ((task   (tasks:snag-a-task dbstruct))
;; 	 (action (if task (tasks:task-get-action task) #f)))
;;     (if action (print "tasks:process-queue task: " task))
;;     (if action
;; 	(case (string->symbol action)
;; 	  ((run)       (tasks:start-run     dbstruct task))
;; 	  ((remove)    (tasks:remove-runs   dbstruct task))
;; 	  ((lock)      (tasks:lock-runs     dbstruct task))
;; 	  ;; ((monitor)   (tasks:start-monitor db task))
;; 	  #;((rollup)    (tasks:rollup-runs   dbstruct task))
;; 	  ((updatemeta)(tasks:update-meta   dbstruct task))
;; 	  #;((kill)      (tasks:kill-monitors dbstruct task))))))

(define (tasks:tasks->text tasks)
  (let ((fmtstr "~10a~10a~10a~12a~20a~12a~12a~10a"))
    (conc (format #f fmtstr "id" "action" "owner" "state" "target" "runname" "testpatts" "params") "\n"
	  (string-intersperse 
	   (map (lambda (task)
		  (format #f fmtstr
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822

;; gets mtpg-run-id and syncs the record if different
;;
(define (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)
  (let* ((runs-ht (hash-table-ref cached-info 'runs))
	 (runinf  (hash-table-ref/default runs-ht run-id #f))
         (area-id (vector-ref area-info 0)))
       (if runinf
	runinf ;; already cached
	(let* ((run-dat    (rmt:get-run-info run-id))               ;; NOTE: get-run-info returns a vector < row header >
	       (run-name   (rmt:get-run-name-from-id run-id))
	       (row        (db:get-rows run-dat))                   ;; yes, this returns a single row
	       (header     (db:get-header run-dat))
	       (state      (db:get-value-by-header row header "state"))
	       (status     (db:get-value-by-header row header "status"))
	       (owner      (db:get-value-by-header row header "owner"))
	       (event-time (db:get-value-by-header row header "event_time"))
	       (comment    (db:get-value-by-header row header "comment"))
	       (fail-count (db:get-value-by-header row header "fail_count"))
	       (pass-count (db:get-value-by-header row header "pass_count"))
               (db-contour (db:get-value-by-header row header "contour"))
	       (contour    (if (args:get-arg "-prepend-contour") 
                                 (if (and db-contour (not (equal? db-contour ""))  (string? db-contour )) 
                                           (begin 
                                            (debug:print-info 10 *default-log-port*  "db-contour" db-contour) 
 						db-contour)
					    (args:get-arg "-contour"))))
               (run-tag (if (args:get-arg "-run-tag")
                            (args:get-arg "-run-tag")
									""))
               (last-update (db:get-value-by-header row header "last_update"))
	       (keytarg    (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target"))
	       			(conc "MT_CONTOUR/MT_AREA/" (string-intersperse (rmt:get-keys) "/")) (string-intersperse (rmt:get-keys) "/"))) ;; e.g. version/iteration/platform
               (base-target      (rmt:get-target run-id))
	       (target     (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) 
	       			(conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name) "/")) base-target) base-target))                 ;; e.g. v1.63/a3e1/ubuntu
	       (spec-id    (pgdb:get-ttype dbh keytarg))
	       (publish-time (if (args:get-arg "-cp-eventtime-to-publishtime")
                            event-time
                           (current-seconds))) 
	       (new-run-id (if (and run-name base-target) (pgdb:get-run-id dbh spec-id target run-name area-id) #f)))
         (if new-run-id
	         (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id))
		        (hash-table-set! runs-ht run-id new-run-id)
		;; ensure key fields are up to date
     ;; if last_update == pgdb_last_update do not update smallest-last-update-time  
    (let* ((pgdb-last-update (pgdb:get-run-last-update dbh new-run-id))
           (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)))
     (if (and  (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time)))
        (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
		(pgdb:refresh-run-info
		 dbh
		 new-run-id
		 state status owner event-time comment fail-count pass-count area-id last-update publish-time)
     (debug:print-info 4 *default-log-port* "Working on run-id " run-id " pgdb-id "  new-run-id )
     (if (not (equal? run-tag ""))
      (task:add-run-tag dbh new-run-id run-tag))
		new-run-id) 
      
	      (if (or (not state) (equal? state "deleted"))
          (begin 
          (debug:print-info 1 *default-log-port*  "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f)
          (if (handle-exceptions
		        exn
		        (begin (print-call-chain)
              (print ((condition-property-accessor 'exn 'message) exn))     
			      #f)
            
            (pgdb:insert-run
		     dbh
		     spec-id target run-name state status owner event-time comment fail-count pass-count  area-id last-update publish-time))
		       (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)))
             (if (or (not smallest-time) (< last-update smallest-time))
        				(hash-table-set! smallest-last-update-time "smallest-time" last-update))
             (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
		  #f)))))))

(define (task:add-run-tag dbh run-id tag) 
  (let* ((tag-info (pgdb:get-tag-info-by-name dbh tag)))
   (if (not tag-info)
     (begin   
     (if (handle-exceptions
	   exn







|














|
|

|
|


|


|





|
|

|
|
|

|
|
|
|
|





|
|

|

|
|
|
|
|
|

|
|
|
|
|
|
|
|
|







740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822

;; gets mtpg-run-id and syncs the record if different
;;
(define (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)
  (let* ((runs-ht (hash-table-ref cached-info 'runs))
	 (runinf  (hash-table-ref/default runs-ht run-id #f))
         (area-id (vector-ref area-info 0)))
    (if runinf
	runinf ;; already cached
	(let* ((run-dat    (rmt:get-run-info run-id))               ;; NOTE: get-run-info returns a vector < row header >
	       (run-name   (rmt:get-run-name-from-id run-id))
	       (row        (db:get-rows run-dat))                   ;; yes, this returns a single row
	       (header     (db:get-header run-dat))
	       (state      (db:get-value-by-header row header "state"))
	       (status     (db:get-value-by-header row header "status"))
	       (owner      (db:get-value-by-header row header "owner"))
	       (event-time (db:get-value-by-header row header "event_time"))
	       (comment    (db:get-value-by-header row header "comment"))
	       (fail-count (db:get-value-by-header row header "fail_count"))
	       (pass-count (db:get-value-by-header row header "pass_count"))
               (db-contour (db:get-value-by-header row header "contour"))
	       (contour    (if (args:get-arg "-prepend-contour") 
			       (if (and db-contour (not (equal? db-contour ""))  (string? db-contour )) 
				   (begin 
                                            (debug:print-info 10 *default-log-port*  "db-contour" db-contour) 
				     db-contour)
				   (args:get-arg "-contour"))))
               (run-tag (if (args:get-arg "-run-tag")
                            (args:get-arg "-run-tag")
			    ""))
               (last-update (db:get-value-by-header row header "last_update"))
	       (keytarg    (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target"))
			       (conc "MT_CONTOUR/MT_AREA/" (string-intersperse (rmt:get-keys) "/")) (string-intersperse (rmt:get-keys) "/"))) ;; e.g. version/iteration/platform
               (base-target      (rmt:get-target run-id))
	       (target     (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) 
	       			(conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name) "/")) base-target) base-target))                 ;; e.g. v1.63/a3e1/ubuntu
	       (spec-id    (pgdb:get-ttype dbh keytarg))
	       (publish-time (if (args:get-arg "-cp-eventtime-to-publishtime")
				 event-time
				 (current-seconds))) 
	       (new-run-id (if (and run-name base-target) (pgdb:get-run-id dbh spec-id target run-name area-id) #f)))
	  (if new-run-id
	      (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id))
		(hash-table-set! runs-ht run-id new-run-id)
		;; ensure key fields are up to date
		;; if last_update == pgdb_last_update do not update smallest-last-update-time  
		(let* ((pgdb-last-update (pgdb:get-run-last-update dbh new-run-id))
		       (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)))
		  (if (and  (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time)))
		      (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
		(pgdb:refresh-run-info
		 dbh
		 new-run-id
		 state status owner event-time comment fail-count pass-count area-id last-update publish-time)
     (debug:print-info 4 *default-log-port* "Working on run-id " run-id " pgdb-id "  new-run-id )
		(if (not (equal? run-tag ""))
		    (task:add-run-tag dbh new-run-id run-tag))
		new-run-id) 
	      
	      (if (or (not state) (equal? state "deleted"))
		  (begin 
		    (debug:print-info 1 *default-log-port*  "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f)
		  (if (handle-exceptions
		       exn
		       (begin (print-call-chain)
			      (print ((condition-property-accessor 'exn 'message) exn))     
			      #f)
		       
		       (pgdb:insert-run
			dbh
			spec-id target run-name state status owner event-time comment fail-count pass-count  area-id last-update publish-time))
		      (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)))
			(if (or (not smallest-time) (< last-update smallest-time))
			    (hash-table-set! smallest-last-update-time "smallest-time" last-update))
			(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
		      #f)))))))

(define (task:add-run-tag dbh run-id tag) 
  (let* ((tag-info (pgdb:get-tag-info-by-name dbh tag)))
   (if (not tag-info)
     (begin   
     (if (handle-exceptions
	   exn
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
	   (pgdb:insert-area-tag  dbh   (vector-ref tag-info 0)  (vector-ref area-info 0))))))

(define (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time) 
  (for-each
     (lambda (run-id)
      (debug:print-info 4 *default-log-port*   "Check if run with " run-id " needs to be synced" )
       (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
run-ids))


;; get runs changed since last sync
;; (define (tasks:sync-test-data dbh cached-info area-info)
;;   (let* ((

(define (tasks:sync-to-postgres configdat dest)







|







1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
	   (pgdb:insert-area-tag  dbh   (vector-ref tag-info 0)  (vector-ref area-info 0))))))

(define (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time) 
  (for-each
     (lambda (run-id)
      (debug:print-info 4 *default-log-port*   "Check if run with " run-id " needs to be synced" )
       (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
     run-ids))


;; get runs changed since last sync
;; (define (tasks:sync-test-data dbh cached-info area-info)
;;   (let* ((

(define (tasks:sync-to-postgres configdat dest)

Modified tests.scm from [673927d3ed] to [dccb407cd2].

1714
1715
1716
1717
1718
1719
1720

















1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732


1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
	;;     		  (lambda (x)(equal? "node" (car x)))
	;;     		  (map string-split (tests:easy-dot test-records "plain"))))))
	;;   (map car (sort data (lambda (a b)
	;;     		    (> (string->number (caddr a))(string->number (caddr b)))))))
	;; ))
	(sort all-tests sort-fn1)))) ;; avoid dealing with deleted tests, look at the hash table


















(define (tests:easy-dot test-records outtype)
  (let-values (((fd temp-path) (file-mkstemp (conc "/tmp/" (current-user-name) ".XXXXXX"))))
    (let ((all-testnames (hash-table-keys test-records))
	  (temp-port     (open-output-file* fd)))
      ;; (format temp-port "This file is ~A.~%" temp-path)
      (format temp-port "digraph tests {\n")
      (format temp-port "  size=4,8\n")
      ;; (format temp-port "   splines=none\n")
      (for-each
       (lambda (testname)
	 (let* ((testrec (hash-table-ref test-records testname))
		(waitons (or (tests:testqueue-get-waitons testrec) '())))


	   (for-each
	    (lambda (waiton)
	      (format temp-port (conc "   " waiton " -> " testname " [splines=ortho]\n")))
	    waitons)))
       all-testnames)
      (format temp-port "}\n")
      (close-output-port temp-port)
      (with-input-from-pipe
       (conc "env -i PATH=$PATH dot -T" outtype " < " temp-path)
       (lambda ()
	 (let ((res (read-lines)))







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











|
>
>



|







1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
	;;     		  (lambda (x)(equal? "node" (car x)))
	;;     		  (map string-split (tests:easy-dot test-records "plain"))))))
	;;   (map car (sort data (lambda (a b)
	;;     		    (> (string->number (caddr a))(string->number (caddr b)))))))
	;; ))
	(sort all-tests sort-fn1)))) ;; avoid dealing with deleted tests, look at the hash table

;; look up all waitons that are related to test "testname"
;;
(define (tests:get-mt-waitons testname flatten)
  (let* ((mt-waitons    (configf:get-section *configdat* "waitons"))
	 (my-waitons    (filter
			 (lambda (x)
			   (string-match (conc "^(" testname "|" testname"/.*)$") (car x)))
			 mt-waitons)))
    (if flatten
	(map (lambda (w)
	       (car (string-split w "/")))
	     (apply append (map (lambda (x)
				  (string-split (cadr x)))
				my-waitons)))
	my-waitons)))

;; NOT USED
(define (tests:easy-dot test-records outtype)
  (let-values (((fd temp-path) (file-mkstemp (conc "/tmp/" (current-user-name) ".XXXXXX"))))
    (let ((all-testnames (hash-table-keys test-records))
	  (temp-port     (open-output-file* fd)))
      ;; (format temp-port "This file is ~A.~%" temp-path)
      (format temp-port "digraph tests {\n")
      (format temp-port "  size=4,8\n")
      ;; (format temp-port "   splines=none\n")
      (for-each
       (lambda (testname)
	 (let* ((testrec (hash-table-ref test-records testname))
		(waitons (or (tests:testqueue-get-waitons testrec) '()))
		(my-mt-waitons (tests:get-mt-waitons testname #t)))
	   ;; (print "my-mt-waitons=" my-mt-waitons)
	   (for-each
	    (lambda (waiton)
	      (format temp-port (conc "   " waiton " -> " testname " [splines=ortho]\n")))
	    (append waitons my-mt-waitons))))
       all-testnames)
      (format temp-port "}\n")
      (close-output-port temp-port)
      (with-input-from-pipe
       (conc "env -i PATH=$PATH dot -T" outtype " < " temp-path)
       (lambda ()
	 (let ((res (read-lines)))
1758
1759
1760
1761
1762
1763
1764


1765
1766
1767
1768
1769
1770
1771

1772
1773
1774
1775
1776
1777
1778
		   (tal (cdr all-testnames))
		   (res (list "digraph tests {"
			      (conc " size=\"" (or sizex 11) "," (or sizey 11) "\";")
			      " ratio=0.95;"
			      )))
	  (let* ((testrec (hash-table-ref test-records hed))
		 (waitons (or (tests:testqueue-get-waitons testrec) '()))


		 (newres  (append res
				  (if (null? waitons)
				      (list (conc "   \"" hed "\" [shape=box];"))
				      (map (lambda (waiton)
					     (conc "   \"" waiton "\" -> \"" hed "\" [shape=box];"))
					   waitons)
				      ))))

	    (if (null? tal)
		(append newres (list "}"))
		(loop (car tal)(cdr tal) newres)
		))))))

;; (tests:run-dot (list "digraph tests {" "a -> b" "}") "plain")








>
>

|



|
<
>







1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791

1792
1793
1794
1795
1796
1797
1798
1799
		   (tal (cdr all-testnames))
		   (res (list "digraph tests {"
			      (conc " size=\"" (or sizex 11) "," (or sizey 11) "\";")
			      " ratio=0.95;"
			      )))
	  (let* ((testrec (hash-table-ref test-records hed))
		 (waitons (or (tests:testqueue-get-waitons testrec) '()))
		 (my-mt-waitons (tests:get-mt-waitons hed #t))
		 (all-waitons   (delete-duplicates (append waitons my-mt-waitons)))
		 (newres  (append res
				  (if (null? all-waitons)
				      (list (conc "   \"" hed "\" [shape=box];"))
				      (map (lambda (waiton)
					     (conc "   \"" waiton "\" -> \"" hed "\" [shape=box];"))
					   all-waitons)))))

	    ;; (debug:print 0 *default-log-port* "For test "hed" got "all-waitons)
	    (if (null? tal)
		(append newres (list "}"))
		(loop (car tal)(cdr tal) newres)
		))))))

;; (tests:run-dot (list "digraph tests {" "a -> b" "}") "plain")

1786
1787
1788
1789
1790
1791
1792

1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809






1810
1811
1812
1813
1814
1815
1816
		 (lambda ()
		   (read-lines)))))
      (close-input-port inp)
      res)))

;; read data from tmp file or create if not exists
;; if exists regen in background

;;
(define (tests:lazy-dot testrecords  outtype sizex sizey)
  (let ((dfile (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dot"))
	(fname (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dotdat")))
    (tests:write-dot-file testrecords dfile sizex sizey)
    (if (common:file-exists? fname)
	(let ((res (with-input-from-file fname
		     (lambda ()
		       (read-lines)))))
	  (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname "&"))
	  res)
	(begin
	  (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname))
	  (with-input-from-file fname
	    (lambda ()
	      (read-lines)))))))
	  







;; for each test:
;;   
(define (tests:filter-non-runnable run-id testkeynames testrecordshash)
  (let ((runnables '()))
    (for-each
     (lambda (testkeyname)







>

|



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







1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
		 (lambda ()
		   (read-lines)))))
      (close-input-port inp)
      res)))

;; read data from tmp file or create if not exists
;; if exists regen in background
;; mode: raw (return data as read) or munged (convert to list of lists and remove " from strings)
;;
(define (tests:lazy-dot testrecords  outtype sizex sizey mode)
  (let ((dfile (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dot"))
	(fname (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dotdat")))
    (tests:write-dot-file testrecords dfile sizex sizey)
    (let ((data (if (common:file-exists? fname)
		    (let ((res (with-input-from-file fname
				 (lambda ()
				   (read-lines)))))
		      (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname "&"))
		      res)
		    (begin
		      (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname))
		      (with-input-from-file fname
			(lambda ()
			  (read-lines)))))))
      (if (eq? mode 'raw)
	  data
	  (map (lambda (inl)
		 (map (lambda (s)
			(string-substitute "\"" "" s #t))
		      (string-split inl)))
	       data)))))

;; for each test:
;;   
(define (tests:filter-non-runnable run-id testkeynames testrecordshash)
  (let ((runnables '()))
    (for-each
     (lambda (testkeyname)
1977
1978
1979
1980
1981
1982
1983

1984




















1985


1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998

1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
	 (lambda (count)
	   (set! res count))
	 tdb
	 "SELECT count(id) FROM test_rundat;")
	res))
  0)


(define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)




















  (rmt:general-call 'update-test-rundat run-id test-id (current-seconds) (or cpuload -1)(or diskfree -1) -1 (or minutes -1))


  (if (and cpuload diskfree)
      (rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id))
  (if minutes 
      (rmt:general-call 'update-run-duration run-id minutes test-id))
  (if (and uname hostname)
      (rmt:general-call 'update-uname-host run-id uname hostname test-id)))
  
;; This one is for running with no db access (i.e. via rmt: internally)
(define (tests:set-full-meta-info db test-id run-id minutes work-area remtries)
;; (define (tests:set-full-meta-info test-id run-id minutes work-area)
;;  (let ((remtries 10))
  (let* ((cpuload  (get-cpu-load))
	 (diskfree (get-df (current-directory)))

	 (uname    (get-uname "-srvpio"))
	 (hostname (get-host-name)))
    (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)))
    
;; (define (tests:set-partial-meta-info test-id run-id minutes work-area)
#;(define (tests:set-partial-meta-info test-id run-id minutes work-area remtries)
  (let* ((cpuload  (get-cpu-load))
	 (diskfree (get-df (current-directory)))
	 (remtries 10))
    (handle-exceptions







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


|




>


|







2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
	 (lambda (count)
	   (set! res count))
	 tdb
	 "SELECT count(id) FROM test_rundat;")
	res))
  0)

;; 
(define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname #!key (update-db #f)(tmpfree #f))
  (if (get-environment-variable "MT_TEST_RUN_DIR")
      (let* ((dest-dir (conc (get-environment-variable "MT_TEST_RUN_DIR") "/.mt_data"))
	     (or-dash  (lambda (instr)
			 (cond
			  ((not instr) "") ;; #f -> blank, indicates value unchanged since last measurement taken
			  ((string? instr)(if (string-search " " instr) (conc "\"" instr "\"") instr))
			  (else instr))))
	     (file-new (not (directory-exists? dest-dir))))
	(if file-new (create-directory dest-dir #t))
	(let* ((outp (open-output-file (conc dest-dir "/test-run.dat") #:append)))
	  (with-output-to-port outp
	    (lambda ()
	      (if file-new
		  (print "epoch_time,run_id,test_id,cpuload,diskfree,tmpfree,run_minutes,hostname,uname"))
	      (print (current-seconds) "," (or-dash run-id)   "," (or-dash test-id)  ","
		     (or-dash cpuload) "," (or-dash diskfree) "," (or-dash tmpfree)  ","
		     (or-dash minutes) "," (or-dash hostname) ","
		     (or-dash uname)))) ;; put uname last as it has spaces in it
	  (close-output-port outp)))
      (begin
	(rmt:general-call 'update-test-rundat run-id test-id (current-seconds) (or cpuload -1)(or diskfree -1) -1 (or minutes -1))))
  (if update-db
      (begin
	(if (and cpuload diskfree)
	    (rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id))
	(if minutes 
	    (rmt:general-call 'update-run-duration run-id minutes test-id))
	(if (and uname hostname)
	    (rmt:general-call 'update-uname-host run-id uname hostname test-id)))))
  
;; This one is for running with no db access (i.e. via rmt: internally)
(define (tests:set-full-meta-info db test-id run-id minutes work-area remtries #!key (update-db #f))
;; (define (tests:set-full-meta-info test-id run-id minutes work-area)
;;  (let ((remtries 10))
  (let* ((cpuload  (get-cpu-load))
	 (diskfree (get-df (current-directory)))
	 (tmpfree  (get-df "/tmp"))
	 (uname    (get-uname "-srvpio"))
	 (hostname (get-host-name)))
    (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname update-db: update-db tmpfree: tmpfree)))
    
;; (define (tests:set-partial-meta-info test-id run-id minutes work-area)
#;(define (tests:set-partial-meta-info test-id run-id minutes work-area remtries)
  (let* ((cpuload  (get-cpu-load))
	 (diskfree (get-df (current-directory)))
	 (remtries 10))
    (handle-exceptions

Modified utils/remrun from [7a107135c8] to [c7d387d56c].

38
39
40
41
42
43
44






45

__EOF
  exit
fi

export NBFAKE_HOST=$1
shift






exec nbfake $*







>
>
>
>
>
>
|
38
39
40
41
42
43
44
45
46
47
48
49
50
51

__EOF
  exit
fi

export NBFAKE_HOST=$1
shift
cmd=""
for var in $(env | egrep "^(PARENT_|MT_)"|cut -d= -f1);do
  new_var="`echo ${!var}`"
  cmd="$cmd export $var=$new_var;" 
done
cmd="$cmd $*"
exec nbfake $cmd