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

[mhenoch at common-lisp.net]

Author: mhenoch
Date: Wed Nov 22 15:30:46 2006
New Revision: 68

Modified:
   cl-darcs/trunk/diff.lisp
Log:
Add diff-repo


Modified: cl-darcs/trunk/diff.lisp
==============================================================================
--- cl-darcs/trunk/diff.lisp	(original)
+++ cl-darcs/trunk/diff.lisp	Wed Nov 22 15:30:46 2006
@@ -55,3 +55,41 @@
 	  patches)))
 
     (nreverse patches)))
+
+(defun diff-repo (repo &optional original modified)
+  "Find changes in REPO from pristine tree.
+Return a list of patches.
+ORIGINAL and MODIFIED specify directories to start from."
+  (setf repo (fad:pathname-as-directory repo))
+  (unless (and original modified)
+    (setf modified repo)
+    (setf original (upath-subdir repo '("_darcs" "pristine"))))
+
+  (let* ((wild (make-pathname :directory '(:relative :wild-inferiors)
+			      :name :wild
+			      :type :wild
+			      :version :wild))
+	 (repo-wild (merge-pathnames wild repo))
+	 (original-wild (merge-pathnames wild original))
+	 (modified-wild (merge-pathnames wild modified))
+	 patches)
+    (dolist (original-pathname (fad:list-directory original))
+      (let ((relative-pathname 
+	     (translate-pathname original-pathname original-wild repo-wild))
+	    (modified-pathname
+	     (translate-pathname original-pathname original-wild modified-wild)))
+	(cond
+	  ((fad:directory-pathname-p original-pathname)
+	   (format t "~&Skipping directory ~A for now" original-pathname)
+	   ;; 	 (let ((last-element (car (last (pathname-directory original-pathname)))))
+	   ;; 	   (unless (file-boring-p repo last-element)
+	   ;; 	     ;; We have a non-boring subdirectory.
+	   )
+	  (t
+	   (setf patches (nconc patches 
+				(diff-file original-pathname
+					   modified-pathname
+					   :filename 
+					   (pathname-to-string relative-pathname))))))))
+
+    patches))