115 ;; so this is a good place to remove the records for 115 ;; so this is a good place to remove the records for 116 ;; any previous runs 116 ;; any previous runs 117 ;; (db:test-remove-steps db run-id testname itemdat) 117 ;; (db:test-remove-steps db run-id testname itemdat) 118 118 119 ;; from here on out we will open and close the db 119 ;; from here on out we will open and close the db 120 ;; on every access to reduce the probablitiy of 120 ;; on every access to reduce the probablitiy of 121 ;; contention or stuck access on nfs. 121 ;; contention or stuck access on nfs. 122 (sqlite3:finalize! db) | 122 ;; (sqlite3:finalize! db) 123 123 124 (let* ((m (make-mutex)) 124 (let* ((m (make-mutex)) 125 (kill-job? #f) 125 (kill-job? #f) 126 (exit-info (vector #t #t #t)) 126 (exit-info (vector #t #t #t)) 127 (job-thread #f) 127 (job-thread #f) 128 (runit (lambda () 128 (runit (lambda () 129 ;; (let-values 129 ;; (let-values ................................................................................................................................................................................ 148 (loop (+ i 1))) 148 (loop (+ i 1))) 149 ))))) 149 ))))) 150 ;; then, if runscript ran ok (or did not get ca 150 ;; then, if runscript ran ok (or did not get ca 151 ;; do all the ezsteps (if any) 151 ;; do all the ezsteps (if any) 152 (if ezsteps 152 (if ezsteps 153 (let* ((testconfig (read-config (conc work- 153 (let* ((testconfig (read-config (conc work- 154 (ezstepslst (hash-table-ref/default 154 (ezstepslst (hash-table-ref/default 155 (db (open-db))) | 155 ;; (db (open-db)) > 156 ) 156 (if (not (args:get-arg "-server")) | 157 ;; (if (not (args:get-arg "-server")) 157 (server:client-setup db)) | 158 ;; (server:client-setup db)) 158 (if (not (file-exists? ".ezsteps"))(creat 159 (if (not (file-exists? ".ezsteps"))(creat 159 ;; if ezsteps was defined then we are sur 160 ;; if ezsteps was defined then we are sur 160 (if (not (> (length ezstepslst) 0)) 161 (if (not (> (length ezstepslst) 0)) 161 (debug:print 0 "ERROR: ezsteps define 162 (debug:print 0 "ERROR: ezsteps define 162 (let loop ((ezstep (car ezstepslst)) 163 (let loop ((ezstep (car ezstepslst)) 163 (tal (cdr ezstepslst)) 164 (tal (cdr ezstepslst)) 164 (prevstep #f)) 165 (prevstep #f)) ................................................................................................................................................................................ 249 (inexact->exact 250 (inexact->exact 250 (round 251 (round 251 (- 252 (- 252 (current-seconds) 253 (current-seconds) 253 start-seconds))))) 254 start-seconds))))) 254 (kill-tries 0)) 255 (kill-tries 0)) 255 (let loop ((minutes (calc-minutes))) 256 (let loop ((minutes (calc-minutes))) 256 (let* ((db (open-db)) | 257 (let* (;; (db (open-db)) 257 (cpuload (get-cpu-load)) 258 (cpuload (get-cpu-load)) 258 (diskfree (get-df (current-directory 259 (diskfree (get-df (current-directory 259 (tmpfree (get-df "/tmp"))) 260 (tmpfree (get-df "/tmp"))) 260 (if (not (args:get-arg "-server")) | 261 ;; (if (not (args:get-arg "-server")) 261 (server:client-setup db)) | 262 ;; (server:client-setup db)) 262 (if (not cpuload) (begin (debug:print 0 263 (if (not cpuload) (begin (debug:print 0 263 (if (not diskfree) (begin (debug:print 0 264 (if (not diskfree) (begin (debug:print 0 264 (set! kill-job? (test-get-kill-request db 265 (set! kill-job? (test-get-kill-request db 265 (rdb:test-update-meta-info db test-id min 266 (rdb:test-update-meta-info db test-id min 266 (if kill-job? 267 (if kill-job? 267 (begin 268 (begin 268 (mutex-lock! m) 269 (mutex-lock! m) ................................................................................................................................................................................ 283 (system (conc 284 (system (conc 284 (car processes)) 285 (car processes)) 285 (system (conc "kill -9 " 286 (system (conc "kill -9 " 286 (begin 287 (begin 287 (debug:print 0 "WARNING: Re 288 (debug:print 0 "WARNING: Re 288 (test-set-status! db test-i 289 (test-set-status! db test-i 289 (args:get 290 (args:get 290 (sqlite3:finalize! db) | 291 ;; (sqlite3:finalize! db) 291 (exit 1)))) 292 (exit 1)))) 292 (set! kill-tries (+ 1 kill-tries)) 293 (set! kill-tries (+ 1 kill-tries)) 293 (mutex-unlock! m))) 294 (mutex-unlock! m))) 294 (sqlite3:finalize! db) | 295 ;; (sqlite3:finalize! db) 295 (thread-sleep! (+ 10 (random 10))) ;; add 296 (thread-sleep! (+ 10 (random 10))) ;; add 296 (loop (calc-minutes))))))) 297 (loop (calc-minutes))))))) 297 (th1 (make-thread monitorjob)) 298 (th1 (make-thread monitorjob)) 298 (th2 (make-thread runit))) 299 (th2 (make-thread runit))) 299 (set! job-thread th2) 300 (set! job-thread th2) 300 (thread-start! th1) 301 (thread-start! th1) 301 (thread-start! th2) 302 (thread-start! th2) 302 (thread-join! th2) 303 (thread-join! th2) 303 (mutex-lock! m) 304 (mutex-lock! m) 304 (set! db (open-db)) | 305 ;; (set! db (open-db)) 305 (if (not (args:get-arg "-server")) | 306 ;; (if (not (args:get-arg "-server")) 306 (server:client-setup db)) | 307 ;; (server:client-setup db)) 307 (let* ((item-path (item-list->path itemdat)) 308 (let* ((item-path (item-list->path itemdat)) 308 (testinfo (rdb:get-test-info db run-id test-name item-path)) 309 (testinfo (rdb:get-test-info db run-id test-name item-path)) 309 (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) 310 (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) 310 (begin 311 (begin 311 (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:t 312 (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:t 312 (test-set-status! db test-id 313 (test-set-status! db test-id 313 (if kill-job? "KILLED" "COMPLETED") 314 (if kill-job? "KILLED" "COMPLETED") ................................................................................................................................................................................ 462 (toptest-work-area #f) ;; for iterated tests the top test contains data 463 (toptest-work-area #f) ;; for iterated tests the top test contains data 463 (diskpath #f) 464 (diskpath #f) 464 (cmdparms #f) 465 (cmdparms #f) 465 (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x) 466 (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x) 466 (mt-bindir-path #f) 467 (mt-bindir-path #f) 467 (item-path (item-list->path itemdat)) 468 (item-path (item-list->path itemdat)) 468 (testinfo (rdb:get-test-info db run-id test-name item-path)) 469 (testinfo (rdb:get-test-info db run-id test-name item-path)) 469 (test-id (db:test-get-id testinfo))) | 470 (test-id (db:test-get-id testinfo)) > 471 (debug-param (if (args:get-arg "-debug")(list "-debug" (args:get-arg "- 470 (if hosts (set! hosts (string-split hosts))) 472 (if hosts (set! hosts (string-split hosts))) 471 ;; set the megatest to be called on the remote host 473 ;; set the megatest to be called on the remote host 472 (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest 474 (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest 473 (set! mt-bindir-path (pathname-directory remote-megatest)) 475 (set! mt-bindir-path (pathname-directory remote-megatest)) 474 (if launcher (set! launcher (string-split launcher))) 476 (if launcher (set! launcher (string-split launcher))) 475 ;; set up the run work area for this test 477 ;; set up the run work area for this test 476 (set! diskpath (get-best-disk *configdat*)) 478 (set! diskpath (get-best-disk *configdat*)) ................................................................................................................................................................................ 498 (list 'runname runname) 500 (list 'runname runname) 499 (list 'mt-bindir-path mt-bind 501 (list 'mt-bindir-path mt-bind 500 ;; clean out step records from previous run if they exist 502 ;; clean out step records from previous run if they exist 501 (db:delete-test-step-records db run-id test-name itemdat) 503 (db:delete-test-step-records db run-id test-name itemdat) 502 (change-directory work-area) ;; so that log files from the launch process do 504 (change-directory work-area) ;; so that log files from the launch process do 503 (cond 505 (cond 504 ((and launcher hosts) ;; must be using ssh hostname 506 ((and launcher hosts) ;; must be using ssh hostname 505 (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig " | 507 (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig " 506 (launcher 508 (launcher 507 (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" c | 509 (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" c 508 (else 510 (else 509 (if (not useshell)(debug:print 0 "WARNING: internal launching will not wor 511 (if (not useshell)(debug:print 0 "WARNING: internal launching will not wor 510 (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if usesh | 512 (set! fullcmd (append (list remote-megatest test-sig "-execute" cmdparms) 511 (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) 513 (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) 512 (debug:print 1 "Launching megatest for test " test-name " in " work-area" .. 514 (debug:print 1 "Launching megatest for test " test-name " in " work-area" .. 513 (test-set-status! db test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results l 515 (test-set-status! db test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results l 514 ;; set pre-launch-env-vars before launching, keep the vars in prevvals and p 516 ;; set pre-launch-env-vars before launching, keep the vars in prevvals and p 515 (debug:print 4 "fullcmd: " fullcmd) 517 (debug:print 4 "fullcmd: " fullcmd) 516 (let* ((commonprevvals (alist->env-vars 518 (let* ((commonprevvals (alist->env-vars 517 (hash-table-ref/default *configdat* "env-override" ' 519 (hash-table-ref/default *configdat* "env-override" '