Megatest

Check-in [945796098d]
Login
Overview
Comment:Fixed the removal of test and run directories.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | v1.65-fixes
Files: files | file ages | folders
SHA1: 945796098d68cf1eaf4687406f93c48830407e9b
User & Date: mmgraham on 2020-03-05 09:45:42
Other Links: branch diff | manifest | tags
Context
2020-03-05
09:45
Fixed the removal of test and run directories. Closed-Leaf check-in: 945796098d user: mmgraham tags: v1.65-fixes
2020-03-02
22:43
fixed get-tests-for-run-state-status check-in: dc5b909cd0 user: matt tags: v1.65-fixes
Changes

Modified runs.scm from [6eaaaab4fe] to [e3f5a06ce2].

2137
2138
2139
2140
2141
2142
2143

2144
2145
2146
2147
2148
2149
2150
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151







+







	 (let* ((run-id    (db:get-value-by-header run header "id"))
		(run-state (db:get-value-by-header run header "state"))
		(run-name  (db:get-value-by-header run header "runname"))
		(tests     (if (not (equal? run-state "locked"))
			       (proc-get-tests run-id)
			       '()))
		(lasttpath "/does/not/exist/I/hope")
    (lastrealpath "/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)
                    (tasks:kill-runner target run-name "%")
2313
2314
2315
2316
2317
2318
2319





2320

2321
2322
2323
2324
2325
2326
2327
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334







+
+
+
+
+

+







                                              (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f)
                                              (thread-sleep! 1)))
                                        ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ...
                                        (if (null? tal)
                                            (loop new-test-dat tal)
                                            (loop (car tal)(append tal (list new-test-dat)))))
                                      (begin
                                        (set! lasttpath (db:test-get-rundir new-test-dat)) ;; remember this path for run removal
                                        (if (file-exists? lasttpath) 
                                          (set! lastrealpath (resolve-pathname lasttpath))
                                          (set! lastrealpath lasttpath)
                                        )
                                        (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
2390
2391
2392
2393
2394
2395
2396


2397
2398
2399
2400
2401
2402
2403
2404
2405
2406















2407
2408
2409
2410
2411



2412
2413
2414
2415
2416
2417



2418
2419
2420
2421
2422
2423
2424
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406









2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421





2422
2423
2424
2425
2426
2427
2428


2429
2430
2431
2432
2433
2434
2435
2436
2437
2438







+
+

-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
+
+
+




-
-
+
+
+







		     (if worker-thread (thread-join! worker-thread)))
                   (common:join-backgrounded-threads))))
	   ;; remove the run if zero tests remain
	   (if (eq? action 'remove-runs)
	       (let* ((run-id   (db:get-value-by-header run header "id")) ;; NB// masks run-id from above?
                      (remtests (mt:get-tests-for-run run-id #f '("DELETED") '("n/a") not-in: #t)))
		 (if (null? remtests) ;; no more tests remaining
         ;; Remove the last dir from the path.
         ;; And same for the link-resolved path
		     (let* ((dparts  (string-split lasttpath "/"))
			    (runpath (conc "/" (string-intersperse 
						(take dparts (- (length dparts) 1))
						"/"))))
		       (debug:print 1 *default-log-port* "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record")
                       (if (not keep-records)
                           (begin
                             (rmt:delete-run run-id)
                             (rmt:delete-old-deleted-test-records)))
                           ;; (rmt:set-var "DELETED_TESTS" (current-seconds))
			      (linkspath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))
            (real-dparts (string-split lastrealpath "/"))
			      (realpath (conc "/" (string-intersperse (take real-dparts (- (length real-dparts) 1)) "/")))
            )

            (debug:print 1 *default-log-port* "Removing run: " linkspath)
            (if (not keep-records)
               (begin
                 (debug:print 1 *default-log-port* "Removing DB records for the run.")
                 (rmt:delete-run run-id)
                 (rmt:delete-old-deleted-test-records))
            )
	          (debug:print 1 *default-log-port* "Recursively removing links dir " linkspath)
            (runs:recursive-delete-with-error-msg linkspath)

		       ;; need to figure out the path to the run dir and remove it if empty
		       ;;    (if (null? (glob (conc runpath "/*")))
		       ;;        (begin
		       ;; 	 (debug:print 1 *default-log-port* "Removing run dir " runpath)
		       ;; 	 (system (conc "rmdir -p " runpath))))
            (debug:print 1 *default-log-port* "Recursively removing real dir " realpath)
            (runs:recursive-delete-with-error-msg realpath)

		       )))))
	 ))
     runs)
    ;; (sqlite3:finalize! (db:delay-if-busy tdbdat))
    )
  #t)
  )
#t
)

(define (runs:remove-test-directory test mode) ;; remove-data-only)
  (let* ((run-dir       (db:test-get-rundir test))    ;; run dir is from the link tree
	 (real-dir      (if (common:file-exists? run-dir)
			    ;; (resolve-pathname run-dir)
			    (common:nice-path run-dir)
			    #f))
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453





2454
2455
2456
2457
2458
2459
2460
2456
2457
2458
2459
2460
2461
2462





2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474







-
-
-
-
-
+
+
+
+
+







      ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f))
      ((remove-all)      (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f))
      ((archive-remove)  (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f)))
    (debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
    (if (and real-dir 
	     (> (string-length real-dir) 5)
	     (common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
	(begin ;; let* ((realpath (resolve-pathname run-dir)))
	  (debug:print-info 1 *default-log-port* "Recursively removing " real-dir)
	  (if (common:file-exists? real-dir)
	      (runs:safe-delete-test-dir real-dir)
	      (debug:print 0 *default-log-port* "WARNING: test dir " real-dir " appears to not exist or is not readable")))
	(let* ((realpath (resolve-pathname run-dir)))
	  (debug:print-info 1 *default-log-port* "Recursively removing " realpath)
	  (if (common:file-exists? realpath)
	      (runs:safe-delete-test-dir realpath)
	      (debug:print 0 *default-log-port* "WARNING: test dir " realpath " appears to not exist or is not readable")))
	(if real-dir 
	    (debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist")
	    (debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done")))
    (if (symbolic-link? run-dir)
	(begin
	  (debug:print-info 1 *default-log-port* "Removing symlink " run-dir)
	  (handle-exceptions