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

[mhenoch at common-lisp.net]

Author: mhenoch
Date: Tue Jul 11 12:08:36 2006
New Revision: 22

Modified:
   cl-darcs/trunk/get.lisp
Log:
Read patchinfo structures per tag.  Write proper inventory files when getting a tree.


Modified: cl-darcs/trunk/get.lisp
==============================================================================
--- cl-darcs/trunk/get.lisp	(original)
+++ cl-darcs/trunk/get.lisp	Tue Jul 11 12:08:36 2006
@@ -22,12 +22,16 @@
   ;; other access methods later...
   ;; XXX: checkpoints?
   (let* ((repodir (make-upath inrepodir))
+	 ;; Here we get a list of lists.  Each list represents a tag;
+	 ;; the latest tag is at the head.  Each list contains patches
+	 ;; in the order they are to be applied.
 	 (patchinfo-list (read-repo-patch-list repodir))
 	 ;; We should probably download checkpoint patches, btw...
 	 (checkpoint (when partial
 		       (car (last (read-checkpoint-list repodir))))))
     ;; Create directories...
     (prepare-new-repo outname)
+    (set-default-repo outname inrepodir)
 
     (when checkpoint
       (format t "~&Copying checkpoint...")
@@ -37,11 +41,14 @@
 	(apply-patch checkpoint-patch outname))
       (format t "done"))
 
+    (write-inventory outname patchinfo-list)
+
     (let ((patches (if checkpoint
+		       ;; XXX: patchinfo-list is a list of lists now
 		       (find-remaining-patches patchinfo-list checkpoint)
-		       patchinfo-list)))
+		       (apply #'append (reverse patchinfo-list)))))
       (copy-repo-patches repodir outname patches)
-
+      
       (if (or (null query) (y-or-n-p "Apply patches?"))
 	  (progn
 	    (format t "~&Applying patches")
@@ -84,16 +91,21 @@
   (make-dir outname)
   (make-dir (merge-pathnames (make-pathname :directory (list :relative "_darcs"))
 			     outname))
-  (dolist (dir '("patches" "checkpoints" "prefs"))
+  (dolist (dir '("patches" "checkpoints" "prefs" "inventories"))
     (make-dir (merge-pathnames
 	       (make-pathname :directory (list :relative "_darcs" dir))
-	       outname))))
+	       outname)))
+  (write-default-prefs outname))
 
 ;; {lazily,}read_repo in DarcsRepo.lhs
 ;; read_repo_private in DarcsRepo.lhs
 (defun read-repo-patch-list (inrepodir &optional inventory-file)
   "Read patch info for INREPODIR from INVENTORY-FILE.
-Return a list of patchinfo structures."
+Return a list of lists of patchinfo structures.
+
+Note that this function returns patchinfo structures in the order
+they were applied, unlike the real darcs which often uses reverse
+order."
   (when (null inventory-file)
     (setf inventory-file (upath-subdir inrepodir '("_darcs") "inventory")))
   (let (tag-patches patches)
@@ -106,8 +118,9 @@
 		    ;; read the first patch...
 		    (read-patchinfo in))
 		   (new-filename (patchinfo-make-filename tag-patch)))
-	      ;; ...for the first patch is a tag.  Recursively read the
-	      ;; inventory of that file.
+	      ;; ...for the first patch is a tag.  Recursively read
+	      ;; the inventory of that file.  The tag patch then goes
+	      ;; at the head of the current list of patches.
 	      (setf tag-patches
 		    (read-repo-patch-list
 		     inrepodir (upath-subdir inrepodir '("_darcs" "inventories") new-filename)))
@@ -117,10 +130,11 @@
       ;; Then, just read all patches in the file.
       (format t "~&Reading patchinfo from ~A" inventory-file)
       (setf patches
-	    (loop for patch = (read-patchinfo in)
-	       while patch collect patch
-	       do (princ #\.))))
-    (nconc tag-patches patches)))
+	    (nconc patches
+		   (loop for patch = (read-patchinfo in)
+		      while patch collect patch
+		      do (princ #\.)))))
+    (cons patches tag-patches)))
 
 (defun read-patch-from-repo (repodir patchinfo)
   "Read patch named by PATCHINFO from REPODIR."
@@ -181,3 +195,48 @@
 			     (upath-subdir from '("_darcs" "checkpoints") filename)
 			     :binary t))
 	(fad:copy-stream in out)))))
+
+(defun write-inventory (out patchinfo-list &optional file)
+  "Write PATCHINFO-LIST as inventory in OUT.
+FILE is either nil, meaning the main \"inventory\" file, or a
+string naming a file in the \"inventories\" directory."
+  ;; XXX: slightly_optimize_patchset?
+  (let ((inventory-file (cond
+			  ((null file)
+			   (merge-pathnames
+			    (make-pathname :directory '(:relative "_darcs")
+					   :name "inventory")
+			    out))
+			  (t
+			   (merge-pathnames
+			    (make-pathname :directory '(:relative "_darcs" "inventories")
+					   :name file)
+			    out)))))
+    (with-open-file (f inventory-file :direction :output :if-exists :supersede
+		       :element-type '(unsigned-byte 8))
+      (flet ((print-patchinfos (patchinfos)
+	       ;; Convert output to binary, using the most direct possible
+	       ;; method...
+	       (dolist (patchinfo patchinfos)
+		 (map nil (lambda (char)
+			    (write-byte (char-code char) f))
+		      (with-output-to-string (strout)
+			(write-patchinfo patchinfo strout)))
+		 (write-byte 10 f))))
+	(cond
+	  ((null patchinfo-list)
+	   ;; No patches - empty inventory file.  Nothing to do.
+	   )
+	  ((null (cdr patchinfo-list))
+	   ;; One patch list - no remaining tags.
+
+	   (print-patchinfos (car patchinfo-list)))
+	  (t
+	   ;; Several patch lists, one for each tag
+	   (let* ((this-tag (car patchinfo-list))
+		  (other-tags (cdr patchinfo-list))
+		  (tag-name (patchinfo-make-filename (car this-tag))))
+	     (write-inventory out other-tags tag-name)
+	     (write-sequence (map 'vector #'char-code "Starting with tag:") f)
+	     (write-byte 10 f)
+	     (print-patchinfos (car patchinfo-list)))))))))