Megatest

Check-in [900b334740]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:killrun feature passes killrun test
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.65-killrun
Files: files | file ages | folders
SHA1: 900b334740ad45bcbcfc7421e0703a51890f05c5
User & Date: bjbarcla on 2019-01-30 14:49:57
Other Links: branch diff | manifest | tags
Context
2019-01-30
15:07
added kill-run action to mtutil Leaf check-in: 017981efcd user: bjbarcla tags: v1.65-killrun
14:49
killrun feature passes killrun test check-in: 900b334740 user: bjbarcla tags: v1.65-killrun
2019-01-29
00:36
wip check-in: d9e675ce75 user: bb tags: v1.65-killrun
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified megatest.scm from [3b556aba2a] to [85417a9093].

︙
290
291
292
293
294
295
296
297

298
299
300
301
302
303
304

290
291
292
293
294
295
296

297
298
299
300
301
302
303
304








-
+








			"-itempatt"
			"-setlog"
			"-set-toplog"
			"-runstep"
			"-logpro"
			"-m"
			"-rerun"
                        "-kill-runs"

			"-days"
			"-rename-run"
			"-to"
			;; values and messages
			":category"
			":variable"
			":value"
︙
403
404
405
406
407
408
409

410
411
412
413
414
415
416

403
404
405
406
407
408
409
410
411
412
413
414
415
416
417








+









			;; queries
			"-test-paths" ;; get path(s) to a test, ordered by youngest first

			"-runall"    ;; run all tests, respects -testpatt, defaults to %
			"-run"       ;; alias for -runall
			"-remove-runs"
                        "-kill-runs"
                        "-keep-records" ;; use with -remove-runs to remove only the run data
			"-rebuild-db"
			"-cleanup-db"
			"-rollup"
			"-update-meta"
			"-create-megatest-area"
			"-mark-incompletes"
︙
1038
1039
1040
1041
1042
1043
1044
1045

1046
1047
1048
1049
1050
1051
1052

1039
1040
1041
1042
1043
1044
1045

1046
1047
1048
1049
1050
1051
1052
1053








-
+








     ((not target)
      (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify -target or -reqtarg")
      (exit 1))
     ((not (or (args:get-arg ":runname")
	       (args:get-arg "-runname")))
      (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify the run name pattern with -runname patt")
      (exit 2))
     ((not (args:get-arg "-testpatt"))
     ((not (or (args:get-arg "-testpatt") (eq? action 'kill-runs)))
      (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify the test pattern with -testpatt")
      (exit 3))
     (else
      (if (not (car *configinfo*))
	  (begin
	    (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found")
	    (exit 1))
︙
1065
1066
1067
1068
1069
1070
1071
1072










1073
1074
1075
1076
1077
1078
1079

1066
1067
1068
1069
1070
1071
1072

1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089








-
+
+
+
+
+
+
+
+
+
+








      (set! *didsomething* #t)))))

(if (args:get-arg "-kill-runs")
    (general-run-call 
     "-kill-runs"
     "kill runs"
     (lambda (target runname keys keyvals)
       (operate-on 'kill-runs mode: #f))))
       (operate-on 'kill-runs mode: #f)

       (operate-on 'set-state-status
		   state: (common:args-get-state)
		   status: (common:args-get-status)
		   new-state-status: (args:get-arg "-set-state-status")


                   mode: #f) ;; kill-req on running,launched,remotehoststart things, 
       )))

(if (args:get-arg "-remove-runs")
    (general-run-call 
     "-remove-runs"
     "remove runs"
     (lambda (target runname keys keyvals)
       (operate-on 'remove-runs mode: (if (args:get-arg "-keep-records")
︙

Modified runs.scm from [7e8b238a84] to [82f0950e7f].

︙
2021
2022
2023
2024
2025
2026
2027
2028

2029
2030
2031
2032
2033
2034
2035

2021
2022
2023
2024
2025
2026
2027

2028
2029
2030
2031
2032
2033
2034
2035








-
+








	 (states       (if state  (string-split state  ",") '()))
	 (statuses     (if status (string-split status ",") '()))
	 (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f)))
	 (rp-mutex     (make-mutex))
	 (bup-mutex    (make-mutex))
         (keep-records (args:get-arg "-keep-records"))) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode".

    (let* ((write-access-actions '(remove-runs set-state-status archive run-wait))
    (let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs))
           (dbfile             (conc  *toppath* "/megatest.db"))
           (readonly-mode      (not (file-write-access? dbfile))))
      (when (and readonly-mode
                 (member action write-access-actions))
        (debug:print-error 0 *default-log-port* "megatest.db is readonly.  Cannot proceed with action ["action"] in which write-access isrequired .")
        (exit 1)))
︙
2059
2060
2061
2062
2063
2064
2065
2066
2067

2068

2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082

2059
2060
2061
2062
2063
2064
2065


2066

2067
2068
2069
2070
2071
2072
2073

2074
2075
2076
2077
2078
2079
2080








-
-
+
-
+






-








		(lasttpath "/does/not/exist/I/hope")
		(worker-thread #f))
	   (debug:print-info 4 *default-log-port* "runs:operate-on run=" run ", header=" header)
	   (if (not (null? tests))
	       (begin
		 (case action
                   ((kill-runs)
                    #f
                    (BB> "UNIMPLEMENTED: kill-runs");; TODO: BB implement it.
                    (tasks:kill-runner target run-name "%")
                    (exit 1)
                    (debug:print 1 *default-log-port* "Killing tests for run: " runkey " " (db:get-value-by-header run header "runname"))
                    )
		   ((remove-runs)
		    ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
		    ;; seek and kill in flight -runtests with % as testpatt here
		    ;; (if (equal? testpatt "%")
		    (tasks:kill-runner target run-name testpatt)
		    
		    ;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt))
		    (debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   ((set-state-status)
		    ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
		    (debug:print 1 *default-log-port* "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   ((print-run)
		    (debug:print 1 *default-log-port* "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header)
︙
2176
2177
2178
2179
2180
2181
2182
2183

2184
2185
2186
2187
2188
2189
2190

2174
2175
2176
2177
2178
2179
2180

2181
2182
2183
2184
2185
2186
2187
2188








-
+








                                      ((started)
                                       ;; if last visit was within last second, sleep 1 second
                                       (if (< (- now last-visit) 1.0)
                                           (thread-sleep! 1.0))
                                       (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds))
                                       ;; send to back of line, loop
                                       (let ((newtal (append tal (list test))))
                                        (loop (car newtal)(cdr newtal)))
                                         (loop (car newtal)(cdr newtal)))
                                       )
                                      ((done)
                                       ;; drop this one; if remaining, loop, else finish
                                       (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds))
                                       (let ((subrun-remove-succeeded (hash-table-ref/default backgrounded-remove-result test-fulln 'exception)))
                                         (cond
                                          ((eq? subrun-remove-succeeded 'exception)
︙
2233
2234
2235
2236
2237
2238
2239


















2240
2241
2242
2243
2244
2245
2246

2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








                                            (loop new-test-dat tal)
                                            (loop (car tal)(append tal (list new-test-dat)))))
                                      (begin
                                        (runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
                                        (if (not (null? tal))
                                            (loop (car tal)(cdr tal)))))))
				(rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
                               ((kill-runs)
                                ;; RUNNING -> KILLREQ
                                ;; LAUNCHED,RUNNING,REMOTEHOSTSTART -> NOT STARTED
                                (cond
                                 ((and has-subrun (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")))
                                  (common:send-thunk-to-background-thread
                                   (lambda ()
                                     (let* ((subrun-remove-succeeded
                                             (subrun:kill-subrun run-dir keep-records)))
                                       #t)))
                                  (if (not (null? tal))
				    (loop (car tal)(cdr tal)))
                                  )
                                 ((member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))
                                  (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f)
                                  (if (not (null? tal))
				      (loop (car tal)(cdr tal)))
                                  )))
			       ((set-state-status)
                                (let* ((new-state (car state-status))
                                       (new-status (cadr state-status))
                                       (test-id (db:test-get-id test))
                                       (test-run-dir (db:test-get-rundir new-test-dat))
                                       (has-subrun (and (subrun:subrun-test-initialized? test-run-dir)
                                                      (not (subrun:subrun-removed? test-run-dir)))))
︙

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

︙
116
117
118
119
120
121
122









123
124
125
126
127
128
129

116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138








+
+
+
+
+
+
+
+
+








              (subrun:exec-sub-megatest test-run-dir action-switches-str "remove")))
        (if remove-result
            (begin
              (subrun:set-subrun-removed test-run-dir)
              #t)
            #f))
      #t))

(define (subrun:kill-subrun test-run-dir )
  (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir))
      (let* ((action-switches-str
              (conc "-kill-runs" ))
             (kill-result
              (subrun:exec-sub-megatest test-run-dir action-switches-str "kill")))
        kill-result)
      #t))

(define (subrun:launch-cmd test-run-dir)
  (if (subrun:subrun-removed? test-run-dir)
      (subrun:unset-subrun-removed test-run-dir))      

  (let* ((log-prefix "run")
         (switches (subrun:selector+log-switches test-run-dir log-prefix))
︙

This page was generated in about 0.106s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00