Commit b37057b188c64063a6af7576b5393ea9260f0700

Thomas de Grivel 2015-07-24T19:36:38

Allow specifications to be projected from probed values.

diff --git a/core/defs.lisp b/core/defs.lisp
index 92e319b..a395bd7 100644
--- a/core/defs.lisp
+++ b/core/defs.lisp
@@ -27,6 +27,8 @@
 
 ;;  Properties
 
+(defgeneric compare-property-values (resource property value1 value2))
+
 (defgeneric merge-property-values (resource property old new))
 
 ;;  Probe
@@ -207,6 +209,7 @@
 (defgeneric get-probed (resource property))
 (defgeneric clear-probed% (resource properties))
 (defgeneric describe-probed% (resource output))
+(defgeneric describe-probed-property-value (resource property value))
 
 (defvar *resource*)
 
diff --git a/core/host.lisp b/core/host.lisp
index e6607ca..f5b0900 100644
--- a/core/host.lisp
+++ b/core/host.lisp
@@ -105,12 +105,6 @@
 
 ;;  OS
 
-(defmethod print-object ((os os) stream)
-  (print-unreadable-object (os stream :type t :identity (not *print-pretty*))
-    (with-slots (machine name release version) os
-    (format stream "~A ~A ~A ~A"
-	    name release machine version))))
-
 (defmethod host-os ((host host))
   (get-probed host :os))
 
diff --git a/core/os.lisp b/core/os.lisp
index e240c60..aeb9aa5 100644
--- a/core/os.lisp
+++ b/core/os.lisp
@@ -18,6 +18,19 @@
 
 (in-package :adams)
 
+(defmethod print-object ((os os) stream)
+  (print-unreadable-object (os stream :type t :identity (not *print-pretty*))
+    (with-slots (machine name release version) os
+    (format stream "~A ~A ~A ~A"
+	    name release version machine))))
+
+(defmethod describe-probed-property-value ((resource host)
+                                           (property (eql :os))
+                                           (os os))
+  (with-slots (machine name release version) os
+    (format nil "~A ~A ~A ~A"
+	    name release version machine)))
+
 ;;  UNIX
 
 (defclass os-unix (os) ())
diff --git a/core/properties.lisp b/core/properties.lisp
index b1fab84..fd0cc75 100644
--- a/core/properties.lisp
+++ b/core/properties.lisp
@@ -40,8 +40,11 @@
 (defmacro get-property (property properties)
   `(getf ,properties ,property +undefined+))
 
+(defmethod compare-property-values (resource property value1 value2)
+  (equalp value1 value2))
+
 (defmethod merge-property-values (resource property old new)
-  (unless (equalp old new)
+  (unless (compare-property-values resource property old new)
     (warn "Conflicting values for property ~A in
 ~A
  old: ~S
diff --git a/core/resource.lisp b/core/resource.lisp
index 8fb4d2b..3c892a6 100644
--- a/core/resource.lisp
+++ b/core/resource.lisp
@@ -73,6 +73,11 @@
 #+nil
 (pprint-plist '(:a "aaa" :b "foo" :xyz "bar"))
 
+(defmethod describe-probed-property-value ((resource t)
+                                           (property t)
+                                           value)
+  value)
+
 (defmethod describe-probed% ((res resource) (out (eql :form)))
   (let* ((props (probe-all-properties res))
          (sorted-keys (sort (iter (for* (k v) in props)
@@ -80,7 +85,8 @@
                             #'string<))
          (sorted-props (iter (for key in sorted-keys)
                              (collect key)
-                             (collect (get-property key props)))))
+                             (collect (describe-probed-property-value
+                                       res key (get-property key props))))))
     `(resource ',(class-name (class-of res))
                ,(resource-id res)
                ,@sorted-props)))
diff --git a/core/spec.lisp b/core/spec.lisp
index 577f291..546bf3f 100644
--- a/core/spec.lisp
+++ b/core/spec.lisp
@@ -95,13 +95,10 @@
 
 ;;  Methods for matching specified and probed values
 
-(defgeneric match-specified-value (specified probed))
+(defgeneric match-specified-value (resource property specified probed))
 
-(defmethod match-specified-value (specified probed)
-  (equalp specified probed))
-
-(defmethod match-specified-value ((specified resource) probed)
-  (equalp (resource-id specified) probed))
+(defmethod match-specified-value (resource property specified probed)
+  (equalp specified (describe-probed-property-value resource property probed)))
 
 ;;  Methods to get current status of resource
 
@@ -115,7 +112,7 @@ Second value lists properties in line with spec. Format is
 (defmethod resource-diff ((res resource))
   (iter (for* (property specified) in (specified-properties res))
         (for probed = (get-probed res property))
-        (if (match-specified-value specified probed)
+        (if (match-specified-value res property specified probed)
             (collect `(,property ,specified) into ok)
             (collect `(,property ,specified ,probed) into diff))
         (finally (return (values diff ok)))))