[Cl-darcs-cvs] r128 - cl-darcs/trunk

[mhenoch at common-lisp.net]

Author: mhenoch
Date: Fri Aug 24 08:30:54 2007
New Revision: 128

Modified:
   cl-darcs/trunk/touching.lisp
Log:
Add FIND-TOUCHING methods for DIRECTORY-PATCH and subclasses.  Add warnings for bizarre situations.


Modified: cl-darcs/trunk/touching.lisp
==============================================================================
--- cl-darcs/trunk/touching.lisp	(original)
+++ cl-darcs/trunk/touching.lisp	Fri Aug 24 08:30:54 2007
@@ -75,6 +75,7 @@
      ;; Should this happen in normal circumstances?  If the file was
      ;; created by this patch, noone would know about its existence
      ;; before.
+     (warn "FIND-TOUCHING: File ~A is being added, but it already exists." filename)
      (values patch filename))
     (:backwards
      ;; Before this patch, the file didn't exist.
@@ -88,12 +89,32 @@
      (values patch nil))
     (:backwards
      ;; Should this happen?
+     (warn "FIND-TOUCHING: File ~A was removed, but it still exists." filename)
      (values patch filename))))
 
-(defmethod find-touching ((patch directory-patch) filename direction)
+(defmethod find-touching :around ((patch directory-patch) filename direction)
   (declare (ignore direction))
   (when (equal filename (patch-directory patch))
-    (values patch filename)))
+    (call-next-method)))
+
+(defmethod find-touching ((patch add-dir-patch) filename direction)
+  (ecase direction
+    (:forwards
+     ;; Should this happen?
+     (warn "FIND-TOUCHING: Directory ~A is being added, but it already exists." filename)
+     (values patch filename))
+    (:backwards
+     ;; Before this patch, the directory didn't exist.
+     (values patch nil))))
+
+(defmethod find-touching ((patch rm-dir-patch) filename direction)
+  (ecase direction
+    (:forwards
+     ;; After this patch, the directory doesn't exist.
+     (values patch nil))
+    (:backwards
+     (warn "FIND-TOUCHING: Directory ~A was removed, but it still exists." filename)
+     (values patch filename))))
 
 (defmethod find-touching ((patch named-patch) filename direction)
   (multiple-value-bind (touching-patch new-name)