Skip to content

Commit

Permalink
Added new test to check if error-handler could help.
Browse files Browse the repository at this point in the history
  • Loading branch information
svetlyak40wt committed Jan 15, 2025
1 parent c66a672 commit a40221e
Show file tree
Hide file tree
Showing 2 changed files with 53 additions and 3 deletions.
7 changes: 4 additions & 3 deletions src/mbox/message-box.lisp
Original file line number Diff line number Diff line change
Expand Up @@ -241,7 +241,8 @@ It will be apply'ed with the rest of the args when the message was 'popped' from
(bt2:with-lock-held (withreply-lock)
(log:trace "~a: pushing item to queue: ~a" (name msgbox) push-item)
(queue:pushq queue push-item)
(ensure-thread-is-running msgbox))
;; (ensure-thread-is-running msgbox)
)

;; It is important to leave lock withreply-lock
;; before we will wait for result. Otherwisee handler-fun
Expand All @@ -252,7 +253,7 @@ It will be apply'ed with the rest of the args when the message was 'popped' from
(bt2:with-lock-held (withreply-lock)
(log:trace "~a: pushing item to queue: ~a" (name msgbox) push-item)
(queue:pushq queue push-item)
(ensure-thread-is-running msgbox)
;; (ensure-thread-is-running msgbox)

(log:trace "~a: withreply: waiting for arrival of result..." (name msgbox))
(bt2:condition-wait withreply-cvar withreply-lock))))
Expand Down Expand Up @@ -358,7 +359,7 @@ Returns the handler-result if `withreply-p' is eq to `T', otherwise the return i
(log:debug "~a: enqueuing... withreply-p: ~a, time-out: ~a, message: ~a"
(name self) withreply-p time-out message)
(pushq queue push-item)
(ensure-thread-is-running self)
;; (ensure-thread-is-running self)

(if withreply-p
(dispatch/reply self push-item dispatcher dispatcher-fun-args time-out)
Expand Down
49 changes: 49 additions & 0 deletions tests/message-box-test.lisp
Original file line number Diff line number Diff line change
Expand Up @@ -53,6 +53,7 @@
;; return a result:
nil
(list (lambda (msg)
(declare (ignore msg))
(handler-bind ((serious-condition #'abort))
(error "Die, thread, die!")))))))
(is (equal first-reply
Expand All @@ -70,3 +71,51 @@

;; Cleanup a thread:
(stop box t))))


(test bt-box-resurrects-thread-after-abort-if-handler-catches-all-signals
"Tests that if an error happends during message processing, a thread will remain running."

(let ((box (make-instance 'message-box/bt
:name "foo")))
(unwind-protect
(progn
(let ((first-reply
(submit box "The Message"
t
;; Don't wait for result here, because we are
;; intentionally raise error here and will never
;; return a result:
nil
(list (lambda (msg)
(declare (ignore msg))
(handler-case
;; This way we are simulating that the user choose
;; an ABORT restart in the IDE during debug session:
(handler-bind ((serious-condition #'abort))
(error "Die, thread, die!"))
;; This part the same as error handling code in the
;; SENTO.ACTOR-CELL:HANDLE-MESSAGE function:
;;
;; TODO: t was used to check if it is able to
;; catch stack unwinding because of INVOKE-RESTART,
;; but it cant.
(t (c)
(log:error "error condition was raised: ~%~a~%"
c)
(cons :handler-error c))))))))
(is (equal first-reply
'no-result)))

(wait-while-thread-will-die box)

(let ((result (handler-case
(submit box "The Message" t 1
(list (lambda (msg)
(reverse msg))))
(ask-timeout ()
:timeout))))
(is (string= "egasseM ehT" result))))

;; Cleanup a thread:
(stop box t))))

0 comments on commit a40221e

Please sign in to comment.