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

[mhenoch at common-lisp.net]

Author: mhenoch
Date: Mon Nov 27 16:41:32 2006
New Revision: 74

Modified:
   cl-darcs/trunk/diff.lisp
Log:
Handle added and removed files


Modified: cl-darcs/trunk/diff.lisp
==============================================================================
--- cl-darcs/trunk/diff.lisp	(original)
+++ cl-darcs/trunk/diff.lisp	Mon Nov 27 16:41:32 2006
@@ -22,39 +22,71 @@
   (setf original (make-upath original))
   (setf modified (make-upath modified))
   (let* ((original-lines
-	  (with-open-stream (in (open-upath original :binary t))
-	    (loop for line = (read-binary-line in nil)
-	       while line collect line)))
+	  (if (fad:file-exists-p original)
+	      (with-open-stream (in (open-upath original :binary t))
+		(loop for line = (read-binary-line in nil)
+		   while line collect line))
+	      :nonexistent))
 	 (modified-lines
-	  (with-open-stream (in (open-upath modified :binary t))
-	    (loop for line = (read-binary-line in nil)
-	       while line collect line)))
+	  (if (fad:file-exists-p modified)
+	      (with-open-stream (in (open-upath modified :binary t))
+		(loop for line = (read-binary-line in nil)
+		   while line collect line))
+	      :nonexistent))
 
 	 ;; using equalp is safe (i.e. non-case-clobbering), as
 	 ;; we use bytes instead of characters
-	 (opcodes (difflib:get-opcodes
-		   (make-instance 'difflib:sequence-matcher
-				  :a original-lines
-				  :b modified-lines
-				  :test-function #'equalp)))
+	 (opcodes (when (and (listp original-lines)
+			     (listp modified-lines))
+		    (difflib:get-opcodes
+		     (make-instance 'difflib:sequence-matcher
+				    :a original-lines
+				    :b modified-lines
+				    :test-function #'equalp))))
 
 	 patches)
+    (cond
+      ((and (eql original-lines :nonexistent)
+	    (eql modified-lines :nonexistent))
+       (error "Neither ~A nor ~A exist." original modified))
+      ((eql original-lines :nonexistent)
+       ;; Newly created file
+       ;; XXX: should we automatically add such files?
+       (list
+	(make-instance 'add-file-patch
+		       :filename filename)
+	(make-instance 'hunk-patch
+		       :filename filename
+		       :line-number 1
+		       :old ()
+		       :new modified-lines)))
+      ((eql modified-lines :nonexistent)
+       ;; Removed file
+       (list
+	(make-instance 'hunk-patch
+		       :filename filename
+		       :line-number 1
+		       :old original-lines
+		       :new ())
+	(make-instance 'rm-file-patch
+		       :filename filename)))
+      (t
+       ;; Possibly changed file
+       (dolist (opcode opcodes)
+	 (unless (eql (difflib:opcode-tag opcode) :equal)
+	   (push 
+	    (make-instance 'hunk-patch
+			   :filename filename
+			   :line-number (difflib:opcode-j1 opcode)
+			   :old (subseq original-lines
+					(difflib:opcode-i1 opcode)
+					(difflib:opcode-i2 opcode))
+			   :new (subseq modified-lines
+					(difflib:opcode-j1 opcode)
+					(difflib:opcode-j2 opcode)))
+	    patches)))
 
-    (dolist (opcode opcodes)
-      (unless (eql (difflib:opcode-tag opcode) :equal)
-	 (push 
-	  (make-instance 'hunk-patch
-			 :filename filename
-			 :line-number (difflib:opcode-j1 opcode)
-			 :old (subseq original-lines
-					      (difflib:opcode-i1 opcode)
-					      (difflib:opcode-i2 opcode))
-			 :new (subseq modified-lines
-					      (difflib:opcode-j1 opcode)
-					      (difflib:opcode-j2 opcode)))
-	  patches)))
-
-    (nreverse patches)))
+       (nreverse patches)))))
 
 (defun diff-binary-file (original modified &key filename)
   "Find changes between binary files ORIGINAL and MODIFIED.
@@ -96,34 +128,54 @@
 			      :type :wild
 			      :version :wild))
 	 (repo-wild (merge-pathnames wild repo))
+	 (pristine (upath-subdir repo '("_darcs" "pristine")))
+	 (pristine-wild (merge-pathnames wild pristine))
 	 (original-wild (merge-pathnames wild original))
 	 (modified-wild (merge-pathnames wild modified))
 	 patches)
-    (dolist (original-pathname (fad:list-directory original))
-      (let* ((modified-pathname
-	      (translate-pathname original-pathname original-wild modified-wild))
-	     (pathname-string
-	      (pathname-to-string
-	       (translate-pathname modified-pathname repo-wild wild))))
-	(cond
-	  ((fad:directory-pathname-p original-pathname)
-	   (format t "~&Skipping directory ~A for now" modified-pathname)
-	   (let ((last-element (car (last (pathname-directory original-pathname)))))
-	     (unless (file-boring-p repo last-element)
-	       ;; We have a non-boring subdirectory.
-	       (setf patches (nconc patches
-				    (diff-repo repo original-pathname modified-pathname))))))
+    ;; XXX: check if both directories exist
 
-	  ((file-binary-p repo pathname-string)
-	   (setf patches (nconc patches
-				(diff-binary-file original-pathname
-						  modified-pathname
-						  :filename pathname-string))))
-
-	  (t
-	   (setf patches (nconc patches 
-				(diff-file original-pathname
-					   modified-pathname
-					   :filename pathname-string)))))))
+    ;; With fad:list-directory, we get absolute pathnames.  We make
+    ;; them relative to the "root", so they can be compared.
+    (flet ((original-to-repo-relative (p)
+	     (translate-pathname p pristine-wild wild))
+	   (modified-to-repo-relative (p)
+	     (translate-pathname p repo-wild wild)))
+      ;; We list the files in the current directory, both in the
+      ;; original and the modified tree, and get the union.
+      (let* ((files-in-original 
+	      (mapcar #'original-to-repo-relative
+		      (fad:list-directory original)))
+	     (files-in-modified 
+	      (mapcar #'modified-to-repo-relative
+		      (fad:list-directory modified)))
+	     (files (nunion files-in-original files-in-modified
+			    :test #'equal)))
+	;; Then we iterate through the union.
+	(dolist (file files)
+	  (let ((original-pathname 
+		 (merge-pathnames file pristine))
+		(modified-pathname
+		 (merge-pathnames file repo))
+		(pathname-string
+		 (pathname-to-string file)))
+	    (cond
+	      ((fad:directory-pathname-p file)
+	       (unless (file-boring-p repo pathname-string)
+		 ;; We have a non-boring subdirectory.
+		 (setf patches (nconc patches
+				      (diff-repo repo original-pathname modified-pathname)))))
+
+	      ((file-binary-p repo pathname-string)
+	       (setf patches (nconc patches
+				    (diff-binary-file original-pathname
+						      modified-pathname
+						      :filename pathname-string))))
+
+	      (t
+	       (setf patches (nconc patches 
+				    (diff-file original-pathname
+					       modified-pathname
+					       :filename pathname-string)))))))
 
-    patches))
+	patches))))