Skip to content


Subversion checkout URL

You can clone with
Download ZIP
Browse files

singleton-lock-port is a public property of agent. Improve agent logg…

…ing: avoid log4cl calls in the backrace.
  • Loading branch information...
commit 8bb5dc7d61cacc49e03c9e8b3bfc7e279d676398 1 parent 0c0be97
@avodonosov avodonosov authored
32 agent/agent.lisp
@@ -186,14 +186,15 @@ the PREDICATE."
(dolist (lisp pending-lisps)
((serious-condition (lambda (c)
- (let ((msg (with-output-to-string (s)
- (format s
- "Error of type ~A during tests on ~A: ~A~%"
- (type-of c) (implementation-identifier lisp) c)
- (trivial-backtrace:print-backtrace-to-stream s)
- (format s "~&~%Continuing for the remaining lisps."))))
- (log:error (log:make-logger) msg)
- (go continue)))))
+ (let ((bt (with-output-to-string (s)
+ (trivial-backtrace:print-backtrace-to-stream s))))
+ (log:error "Error of type ~A during tests on ~A: ~A~%~A~%Continuing for the remaining lisps."
+ (type-of c)
+ (implementation-identifier lisp)
+ c
+ bt))
+ (go continue))))
(log:info "Running tests for ~A" (implementation-identifier lisp))
(let ((results-dir (perform-test-run agent
@@ -225,18 +226,17 @@ the PREDICATE."
(defmethod main (agent)
((serious-condition (lambda (c)
- (let ((msg (with-output-to-string (s)
- (format s "Unhandled seriours-condition of type ~A: ~A"
- (type-of c) c)
- (trivial-backtrace:print-backtrace-to-stream s))))
- (log:error (log:make-logger) msg)
- (return-from main))))
+ (let ((bt (with-output-to-string (s)
+ (trivial-backtrace:print-backtrace-to-stream s))))
+ (log:error "Unhandled seriours-condition of type ~A: ~A~%~A"
+ (type-of c) c bt))
+ (return-from main)))
(warning (lambda (w)
(log:warn "A warning is signalled: ~A" w)
- (as-singleton-agent
+ (as-singleton (agent)
+ (log:config :daily (log-file agent) :immediate-flush)
(let ((*response-file-temp-dir* (work-dir agent)))
- (log:config :daily (log-file agent) :immediate-flush)
;; finish the agent initialization
(setf (persistence agent) (init-persistence (persistence-file agent))
(blobstore agent) (test-grid-gae-blobstore:make-blob-store
14 agent/as-singleton-agent.lisp
@@ -13,20 +13,18 @@
(in-package #:test-grid-agent)
-(defparameter +singleton-agent-lock-port+ 7685)
(define-condition another-agent-is-running (simple-error) ())
-(defun execute-as-singleton-agent (body-func)
+(defun execute-as-singleton (agent body-func)
- (let ((s (usocket:socket-listen "localhost" +singleton-agent-lock-port+)))
+ (let ((s (usocket:socket-listen "localhost" (singleton-lock-port agent))))
(unwind-protect (funcall body-func)
(usocket:socket-close s)))
(usocket:address-in-use-error ()
(error 'another-agent-is-running
:format-control "Another agent seems to be already running - our \"lock\" TCP port ~A is already in use."
- :format-arguments (list +singleton-agent-lock-port+)))))
+ :format-arguments (list (singleton-lock-port agent))))))
-(defmacro as-singleton-agent (&body body)
- `(execute-as-singleton-agent (alexandria:named-lambda as-singleton-agent-body ()
- ,@body)))
+(defmacro as-singleton ((agent) &body body)
+ `(execute-as-singleton ,agent (alexandria:named-lambda as-singleton-agent-body ()
+ ,@body)))
10 agent/package.lisp
@@ -28,7 +28,7 @@
(in-package #:test-grid-agent)
-(defparameter +api-version+ '(1 . 1)
+(defparameter +api-version+ '(1 . 2)
"Current version of the test-grid-agent API.")
(defgeneric api-compatible-p (version-required &optional version-provided)
@@ -50,7 +50,13 @@ VERSION-PROVIDED defaults to TEST-GRID-AGENT:+API-VERSION+"))
(user-email :type (or null string) :accessor user-email :initform nil)
;; pathname-designator for the working directory,
;; defaults to <source code root>/work-dir/agent
- (work-dir :accessor work-dir)))
+ (work-dir :accessor work-dir)
+ ;; the tcp port used as a lock to prevent several agents
+ ;; running simultaneously.
+ ;; If you want to ran several agents, assign them all
+ ;; different signlethon-ports and different work-dirs.
+ (singleton-lock-port :type fixnum :accessor singleton-lock-port :initform 7685)))
(defgeneric make-agent ())
Please sign in to comment.
Something went wrong with that request. Please try again.