| ︙ | | |
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
|
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
|
-
+
|
;;
(if (args:get-arg "-clean-cache")
(begin
(set! *didsomething* #t) ;; suppress the help output.
(if (getenv "MT_TARGET") ;; no point in trying if no target
(if (args:get-arg "-runname")
(let* ((toppath (launch:setup))
(linktree (if toppath (configf:lookup *configdat* "setup" "linktree")))
(linktree (common:get-linktree)) ;; (if toppath (configf:lookup *configdat* "setup" "linktree")))
(runtop (conc linktree "/" (getenv "MT_TARGET") "/" (args:get-arg "-runname")))
(files (if (file-exists? runtop)
(append (glob (conc runtop "/.megatest*"))
(glob (conc runtop "/.runconfig*")))
'())))
(if (null? files)
(debug:print-info 0 *default-log-port* "No cached megatest or runconfigs files found. None removed.")
|
| ︙ | | |
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
|
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
|
-
+
-
|
(set! *didsomething* #t)))
(if (or (args:get-arg "-list-servers")
(args:get-arg "-stop-server")
(args:get-arg "-kill-server"))
(let ((tl (launch:setup)))
(if tl
(let* ((tdbdat (tasks:open-db))
(let* ((servers (server:get-list *toppath*))
(servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))
|
| ︙ | | |
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
|
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
|
-
-
-
-
-
+
+
+
+
+
|
(last-update (vector-ref server 10))
(transport (vector-ref server 11))
(killed #f)
(status (< last-update 20)))
;; (zmq-sockets (if status (server:client-connect hostname port) #f)))
;; no need to login as status of #t indicates we are connecting to correct
;; server
(if (equal? state "dead")
(if (> last-update (* 25 60 60)) ;; keep records around for slighly over a day.
(tasks:server-deregister (db:delay-if-busy tdbdat) hostname pullport: pullport pid: pid action: 'delete))
(if (> last-update 20) ;; Mark as dead if not updated in last 20 seconds
(tasks:server-deregister (db:delay-if-busy tdbdat) hostname pullport: pullport pid: pid)))
;; (if (equal? state "dead")
;; (if (> last-update (* 25 60 60)) ;; keep records around for slighly over a day.
;; (tasks:server-deregister (db:delay-if-busy tdbdat) hostname pullport: pullport pid: pid action: 'delete))
;; (if (> last-update 20) ;; Mark as dead if not updated in last 20 seconds
;; (tasks:server-deregister (db:delay-if-busy tdbdat) hostname pullport: pullport pid: pid)))
(format #t fmtstr id mt-ver pid hostname (conc interface ":" pullport) pubport last-update
(if status "alive" "dead") transport)
(if (or (equal? id sid)
(equal? sid 0)) ;; kill all/any
(begin
(debug:print-info 0 *default-log-port* "Attempting to kill "kill-switch" server with pid " pid)
(tasks:kill-server hostname pid kill-switch: kill-switch)))))
|
| ︙ | | |
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
|
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
|
-
+
|
(display (conc "target: " targetstr " "))
(display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " "))))
runs-spec)
(newline)))))
(for-each
(lambda (test)
(handle-exceptions
(common:debug-handle-exceptions #f
exn
(begin
(debug:print-error 0 *default-log-port* "Bad data in test record? " test)
(print "exn=" (condition->list exn))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port)))
(let* ((test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test))
|
| ︙ | | |