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

[mhenoch at common-lisp.net]

Author: mhenoch
Date: Wed Mar  5 04:17:09 2008
New Revision: 172

Modified:
   cl-darcs/trunk/cmdline.lisp
Log:
Add WITH-REPO and use it for "add".


Modified: cl-darcs/trunk/cmdline.lisp
==============================================================================
--- cl-darcs/trunk/cmdline.lisp	(original)
+++ cl-darcs/trunk/cmdline.lisp	Wed Mar  5 04:17:09 2008
@@ -100,6 +100,13 @@
 		    (destructuring-bind ,operands ,operands-sym
 		      , at body))))))))
 
+(defparameter opt-repodir 
+  (make-option
+   :keyword :repodir
+   :long "repodir"
+   :arg "DIRECTORY"
+   :help "Use DIRECTORY instead of current directory"))
+
 (defun find-repo (&optional (dir *default-pathname-defaults*))
   "Find repository in current directory or above.
 Signal an error if there is none, else return the repository root.
@@ -114,16 +121,39 @@
 	    (find-repo parent-dir)
 	    (error "Not in a darcs repo.")))))
 
-(define-darcs-command add () (&rest files-and-dirs)
+(defmacro with-repo (repodir &body body)
+  "Given a --repodir argument, canonicalize it and change directory accordingly.
+That is, if there is no --repodir option, don't change current directory,
+and bind variable to the repository root directory.
+If there is a --repodir option, ensure it refers to an existing directory,
+and change the current directory to it.
+\(This is actually how the original darcs does it.\)"
+  (let ((original-repodir (gensym)))
+    `(let* ((,original-repodir ,repodir)
+	    (,repodir
+	     (if ,repodir
+		 (or (fad:directory-exists-p ,repodir)
+		     (error "Directory ~A does not exist." ,repodir))
+		 (find-repo)))
+	    ;; If explicit --repodir argument was specified, change directory.
+	    ;; Otherwise, leave it, even if the actual repository is in a
+	    ;; parent directory.
+	    (*default-pathname-defaults* 
+	     (if (null ,original-repodir)
+		 *default-pathname-defaults*
+		 (fad:pathname-as-directory ,repodir))))
+       , at body)))
+
+(define-darcs-command add (repodir) (&rest files-and-dirs 
+					   &aux already-there)
   "Add files and directories for later recording.
 
 Usage: darcs add FILE ..."
-  (let ((repo (find-repo))
-	already-there)
+  (with-repo repodir
     (dolist (file files-and-dirs)
       (handler-case
 	  (progn
-	    (add-file repo file)
+	    (add-file repodir file)
 	    ;; (format t "~&Added ~A" file)
 	    )
 	(already-in-repository (c)
@@ -132,7 +162,7 @@
 	  (push (slot-value c 'file) already-there))))
     (when already-there
       (setf already-there (nreverse already-there))
-      (let* ((with-path (mapcar (lambda (f) (merge-pathnames f repo)) already-there))
+      (let* ((with-path (mapcar (lambda (f) (merge-pathnames f repodir)) already-there))
 	     (nfiles 0)
 	     (ndirs 0))
 	(dolist (f with-path)
@@ -166,13 +196,6 @@
 Usage: darcs whatsnew"
   (diff-repo-display (find-repo)))
 
-(defparameter opt-repodir 
-  (make-option
-   :keyword :repodir
-   :long "repodir"
-   :arg "DIRECTORY"
-   :help "Use DIRECTORY instead of current directory"))
-
 (define-darcs-command init (repodir) ()
     "Initialize a darcs repository in the current directory.