- cl-darcs-cvs@lists.common-lisp.net - mailman3.common-lisp.net

[Cl-darcs-cvs] r177 - cl-darcs/trunk
by mhenoch＠common-lisp.net 05 Mar '08

05 Mar '08

Author: mhenoch Date: Wed Mar 5 05:44:12 2008 New Revision: 177 Modified: cl-darcs/trunk/cmdline.lisp Log: Check that we don't pull from current repository Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Wed Mar 5 05:44:12 2008 @@ -315,6 +315,10 @@ ;; If no remote repository specified, use the default one. (setf from-repositories (list nil))) + ;; We can't pull from ourselves. + (when (member ourrepo from-repositories :test #'equal) + (error "Can't pull from current repository!")) + (dolist (theirrepo from-repositories) (pull ourrepo theirrepo :select-patches (if all-patches :all :ask)))

1 0

[Cl-darcs-cvs] r176 - cl-darcs/trunk
by mhenoch＠common-lisp.net 05 Mar '08

05 Mar '08

Author: mhenoch Date: Wed Mar 5 05:39:39 2008 New Revision: 176 Modified: cl-darcs/trunk/cmdline.lisp Log: Change default repository when pulling Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Wed Mar 5 05:39:39 2008 @@ -318,4 +318,8 @@ (dolist (theirrepo from-repositories) (pull ourrepo theirrepo :select-patches (if all-patches :all :ask))) + ;; Change the default repository. + (when (first from-repositories) + (set-default-repo ourrepo (upath-to-string (first from-repositories)))) + 0))

1 0

[Cl-darcs-cvs] r175 - cl-darcs/trunk
by mhenoch＠common-lisp.net 05 Mar '08

05 Mar '08

Author: mhenoch Date: Wed Mar 5 04:39:54 2008 New Revision: 175 Modified: cl-darcs/trunk/cmdline.lisp Log: Make FIND-REPO handle its error case properly. FINISH-OUTPUT before reading answers in "record". Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Wed Mar 5 04:39:54 2008 @@ -114,10 +114,11 @@ (if (fad:directory-exists-p (upath-subdir dir '("_darcs"))) (fad:directory-exists-p dir) ;get directory truename (let ((parent-dir (ignore-errors - (merge-pathnames - (make-pathname :directory '(:relative :up)) - dir)))) - (if parent-dir + (fad:directory-exists-p + (merge-pathnames + (make-pathname :directory '(:relative :up)) + dir))))) + (if (and parent-dir (not (equal dir parent-dir))) (find-repo parent-dir) (error "Not in a darcs repo."))))) @@ -245,10 +246,12 @@ ;; XXX: other ways to indicate author (progn (format *query-io* "~&Who is the author? ") + (finish-output *query-io*) (read-line *query-io*)))) (patch-name (or patch-name (progn (format *query-io* "~&What is the patch name? ") + (finish-output *query-io*) (read-line *query-io*)))) (files (mapcar (lambda (file)

1 0

[Cl-darcs-cvs] r174 - cl-darcs/trunk
by mhenoch＠common-lisp.net 05 Mar '08

05 Mar '08

Author: mhenoch Date: Wed Mar 5 04:36:07 2008 New Revision: 174 Modified: cl-darcs/trunk/equal.lisp Log: EQUAL-PATCH: add method for comparing two DIRECTORY-PATCHes Modified: cl-darcs/trunk/equal.lisp ============================================================================== --- cl-darcs/trunk/equal.lisp (original) +++ cl-darcs/trunk/equal.lisp Wed Mar 5 04:36:07 2008 @@ -66,6 +66,12 @@ (compare #'hunk-old-lines) (compare #'hunk-new-lines)))) +(defmethod equal-patch ((a directory-patch) (b directory-patch) &optional really) + "Compare two directory add/remove patches." + (declare (ignore really)) + (and (eq (type-of a) (type-of b)) + (equal (patch-directory a) (patch-directory b)))) + (defmethod equal-patch ((a token-replace-patch) (b token-replace-patch) &optional really) "Compare two token replacing patches." (declare (ignore really))

1 0

[Cl-darcs-cvs] r173 - cl-darcs/trunk
by mhenoch＠common-lisp.net 05 Mar '08

05 Mar '08

Author: mhenoch Date: Wed Mar 5 04:20:37 2008 New Revision: 173 Modified: cl-darcs/trunk/cmdline.lisp Log: Use WITH-REPO for "record" Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Wed Mar 5 04:20:37 2008 @@ -237,48 +237,48 @@ :help "ask for extra dependencies")) (define-darcs-command record - (author all-patches patch-name ask-deps) + (author all-patches patch-name ask-deps repodir) (&rest files) "Save changes in the working copy to the repository as a patch." - (let* ((repo (find-repo)) - (author (or author - ;; XXX: other ways to indicate author - (progn - (format *query-io* "~&Who is the author? ") - (read-line *query-io*)))) - (patch-name (or patch-name - (progn - (format *query-io* "~&What is the patch name? ") - (read-line *query-io*)))) - (files (mapcar - (lambda (file) - (setf file (enough-namestring file repo)) - (if (fad:directory-exists-p file) - (sanitize-filename file :type :directory) - (sanitize-filename file :type :file))) - files))) - ;; XXX: long log - - (let ((patches (diff-repo repo))) - (flet ((ask (patch) - ;; If any files were specified, use only patches - ;; touching those files/directories. - (if (or (null files) - (and (typep patch 'file-patch) - (member (patch-filename patch) files :test #'equal)) - (and (typep patch 'directory-patch) - (member (patch-directory patch) files :test #'equal))) - ;; If all-patches was requested, record all patches - ;; matching the file criterion. - (or all-patches + (with-repo repodir + (let* ((author (or author + ;; XXX: other ways to indicate author (progn - (display-patch patch *query-io*) - (y-or-n-p "Record patch ~A?" patch))) - nil))) - (record-patches repo patch-name author :now nil - (select-patches patches #'ask)) - (format t "~&Finished recording patch '~A'~%" patch-name) - 0)))) + (format *query-io* "~&Who is the author? ") + (read-line *query-io*)))) + (patch-name (or patch-name + (progn + (format *query-io* "~&What is the patch name? ") + (read-line *query-io*)))) + (files (mapcar + (lambda (file) + (setf file (enough-namestring file repodir)) + (if (fad:directory-exists-p file) + (sanitize-filename file :type :directory) + (sanitize-filename file :type :file))) + files))) + ;; XXX: long log + + (let ((patches (diff-repo repodir))) + (flet ((ask (patch) + ;; If any files were specified, use only patches + ;; touching those files/directories. + (if (or (null files) + (and (typep patch 'file-patch) + (member (patch-filename patch) files :test #'equal)) + (and (typep patch 'directory-patch) + (member (patch-directory patch) files :test #'equal))) + ;; If all-patches was requested, record all patches + ;; matching the file criterion. + (or all-patches + (progn + (display-patch patch *query-io*) + (y-or-n-p "Record patch ~A?" patch))) + nil))) + (record-patches repodir patch-name author :now nil + (select-patches patches #'ask)) + (format t "~&Finished recording patch '~A'~%" patch-name) + 0))))) (define-darcs-command pull (all-patches repodir)

1 0

[Cl-darcs-cvs] r172 - cl-darcs/trunk
by mhenoch＠common-lisp.net 05 Mar '08

05 Mar '08

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 ,@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)))) + ,@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.

1 0

[Cl-darcs-cvs] r171 - cl-darcs/trunk
by mhenoch＠common-lisp.net 05 Mar '08

05 Mar '08

Author: mhenoch Date: Wed Mar 5 04:01:41 2008 New Revision: 171 Modified: cl-darcs/trunk/cmdline.lisp Log: Implement "pull" command. Remove obsolete handler case. Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Wed Mar 5 04:01:41 2008 @@ -49,11 +49,6 @@ (progn (warn "~A didn't give a proper exit code." command) 0))) - ;; Catch wrong number of arguments - (program-error (c) - (format *error-output* "~&Program error: ~A" c) - (command-usage command) - 1) (invalid-arguments (c) (with-accessors ((ctrl simple-condition-format-control) (args simple-condition-format-arguments)) c @@ -262,3 +257,39 @@ (format t "~&Finished recording patch '~A'~%" patch-name) 0)))) +(define-darcs-command pull + (all-patches repodir) + (&rest from-repositories) + "Copy and apply patches from another repository to this one." + (let* ((ourrepo + (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 repodir) + *default-pathname-defaults* + (fad:pathname-as-directory ourrepo)))) + + (if from-repositories + ;; Get truename for all repositories, if they are local paths. + (map-into + from-repositories + (lambda (dir) + (setf dir (make-upath dir)) + (when (typep dir 'pathname) + (setf dir (or + (fad:directory-exists-p dir) + (error "Directory ~A does not exist." dir)))) + dir) + from-repositories) + ;; If no remote repository specified, use the default one. + (setf from-repositories (list nil))) + + (dolist (theirrepo from-repositories) + (pull ourrepo theirrepo :select-patches (if all-patches :all :ask))) + + 0))

1 0

[Cl-darcs-cvs] r170 - cl-darcs/trunk
by mhenoch＠common-lisp.net 05 Mar '08

05 Mar '08

Author: mhenoch Date: Wed Mar 5 03:59:08 2008 New Revision: 170 Modified: cl-darcs/trunk/pull.lisp Log: Adapt message when pull finished Modified: cl-darcs/trunk/pull.lisp ============================================================================== --- cl-darcs/trunk/pull.lisp (original) +++ cl-darcs/trunk/pull.lisp Wed Mar 5 03:59:08 2008 @@ -102,4 +102,4 @@ (when source-and-pristine-differ (format t "~&~<Some patches could not be applied to the source tree. ~ You should manually merge changes from the pristine tree in _darcs/pristine/.~>" nil))))) - (format t "~&All done"))) + (format t "~&Finished pulling and applying.")))

1 0

[Cl-darcs-cvs] r169 - cl-darcs/trunk
by mhenoch＠common-lisp.net 05 Mar '08

05 Mar '08

Author: mhenoch Date: Wed Mar 5 03:56:43 2008 New Revision: 169 Modified: cl-darcs/trunk/pull.lisp cl-darcs/trunk/upath.lisp Log: Add UPATH-TO-STRING and use it for saving repository addresses Modified: cl-darcs/trunk/pull.lisp ============================================================================== --- cl-darcs/trunk/pull.lisp (original) +++ cl-darcs/trunk/pull.lisp Wed Mar 5 03:56:43 2008 @@ -31,7 +31,7 @@ (setf theirrepo (car (get-preflist ourrepo "defaultrepo"))) (unless theirrepo (error "No remote repository specified, and no default available."))) - (add-to-preflist ourrepo "repos" theirrepo) + (add-to-preflist ourrepo "repos" (upath-to-string theirrepo)) (let ((motd (get-preflist theirrepo "motd"))) (when motd (format t "~{~&~A~}" motd))) Modified: cl-darcs/trunk/upath.lisp ============================================================================== --- cl-darcs/trunk/upath.lisp (original) +++ cl-darcs/trunk/upath.lisp Wed Mar 5 03:56:43 2008 @@ -80,3 +80,15 @@ (pathname (open upath :direction :input :if-does-not-exist :error :element-type (if binary '(unsigned-byte 8) 'character))))) + +(defun upath-to-string (upath) + "Convert UPATH to a string. +This string can be read with MAKE-UPATH." + (ctypecase upath + (string + upath) + (pathname + (namestring upath)) + (net.uri:uri + (with-output-to-string (s) + (net.uri:render-uri upath s)))))

1 0

[Cl-darcs-cvs] r168 - cl-darcs/trunk
by mhenoch＠common-lisp.net 05 Mar '08

05 Mar '08

Author: mhenoch Date: Wed Mar 5 03:11:37 2008 New Revision: 168 Modified: cl-darcs/trunk/cmdline.lisp Log: FIND-REPO: get truename of directory Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Wed Mar 5 03:11:37 2008 @@ -110,7 +110,7 @@ Signal an error if there is none, else return the repository root. If DIR is specified, search for repository there instead." (if (fad:directory-exists-p (upath-subdir dir '("_darcs"))) - dir + (fad:directory-exists-p dir) ;get directory truename (let ((parent-dir (ignore-errors (merge-pathnames (make-pathname :directory '(:relative :up))

1 0