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
|
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
|
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(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))
(clean-mode (or mode 'remove-all))
(test-id (db:test-get-id test))
(lock-key (conc "test-" test-id))
(got-lock (let loop ((lock (rmt:no-sync-get-lock lock-key))
(expire-time (+ (current-seconds) 30))) ;; 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 clean test with id " test-id)
(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)))))))
;; (lock-key (conc "test-" test-id))
;; (got-lock (let loop ((lock (rmt:no-sync-get-lock lock-key))
;; (expire-time (+ (current-seconds) 30))) ;; 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 clean test with id " test-id)
;; (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)))))))
)
(case clean-mode
((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)
|
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
|
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
|
-
+
+
|
(debug:print 0 *default-log-port* "NOTE: the run dir for this test is undefined. Test may have already been deleted."))
))
;; Only delete the records *after* removing the directory. If things fail we have a record
(case clean-mode
((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) (db:test-get-state test)(db:test-get-status test) #f))
((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f))
(else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test))))
(rmt:no-sync-del! lock-key)))
;; (rmt:no-sync-del! lock-key)
))
;;======================================================================
;; Routines for manipulating runs
;;======================================================================
;; Since many calls to a run require pretty much the same setup
;; this wrapper is used to reduce the replication of code
|