Commit 46bbc15ffd008664d781362723777601aa094ed0
2018-07-26T14:30:11
fix resource-operation-failed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55
diff --git a/core/operation.lisp b/core/operation.lisp
index 0654d84..da2e003 100644
--- a/core/operation.lisp
+++ b/core/operation.lisp
@@ -153,14 +153,42 @@
resource property (hostname host)
(class-name (class-of os))))))
+(defun print-list (x stream)
+ (write-char #\( stream)
+ (let ((first t))
+ (dolist (item x)
+ (if first
+ (setq first nil)
+ (write-char #\Space stream))
+ (if (consp item)
+ (print-list item stream)
+ (prin1 item stream))))
+ (write-char #\) stream))
+
+(defun print-diff (stream diff)
+ (dolist (item diff)
+ (destructuring-bind (property expected probed) item
+ (declare (type symbol property)
+ (type list expected probed))
+ (write-str stream property #\Newline
+ " expected ")
+ (print-list expected stream)
+ (write-str stream #\Newline
+ " probed ")
+ (print-list probed stream)
+ (write-str stream #\Newline))))
+
(defmethod print-object ((c resource-operation-failed) stream)
(if *print-escape*
(call-next-method)
- (with-slots (operation resource diff host os) c
- (format stream "~A failed for (resource '~A ~S) on (host ~S) ~A.~%Conflicting values :~%~{~{~A~% expected ~S~% probed ~S~%~}~}"
- (operation-name operation)
- (string-downcase (class-name (class-of resource)))
- (resource-id resource)
- (hostname host)
- (class-name (class-of os))
- diff))))
+ (let ((*print-level*))
+ (with-slots (operation resource diff host os) c
+ (write-str stream (operation-name operation)
+ " failed for (resource '"
+ (string-downcase (class-name (class-of resource)))
+ " " (prin1-to-string (resource-id resource))
+ ") on (host " (prin1-to-string (hostname host))
+ ") " (class-name (class-of os))
+ "." #\Newline
+ "Conflicting values :" #\Newline)
+ (print-diff stream diff)))))