March 2008 - cl-darcs-cvs@lists.common-lisp.net

[Cl-darcs-cvs] r179 - in cl-darcs/trunk: . tests
by mhenoch＠common-lisp.net 24 Mar '08

24 Mar '08

Author: mhenoch Date: Sun Mar 23 19:38:36 2008 New Revision: 179 Added: cl-darcs/trunk/tests/ cl-darcs/trunk/tests/gcau-tests.lisp cl-darcs/trunk/tests/package.lisp Modified: cl-darcs/trunk/cl-darcs.asd cl-darcs/trunk/repo.lisp Log: Add test suite Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Sun Mar 23 19:38:36 2008 @@ -64,3 +64,21 @@ #+allegro (eval-when (:compile-toplevel :load-toplevel :execute) (require :inflate)) + +(defmethod perform ((o test-op) (c (eql (find-system 'cl-darcs)))) + (operate 'load-op 'cl-darcs-tests) + (operate 'test-op 'cl-darcs-tests :force t)) + +(defsystem cl-darcs-tests + :depends-on (cl-darcs fiveam) + :components + ((:module "tests" + :components ((:file "package") + (:file "gcau-tests"))))) + +(defmethod perform ((o test-op) (c (eql (find-system 'cl-darcs-tests)))) + (operate 'load-op 'cl-darcs-tests) + (funcall (intern (symbol-name '#:run!) + (find-package '#:darcs-tests)) + (intern (symbol-name '#:darcs-suite) + (find-package '#:darcs-tests)))) \ No newline at end of file Modified: cl-darcs/trunk/repo.lisp ============================================================================== --- cl-darcs/trunk/repo.lisp (original) +++ cl-darcs/trunk/repo.lisp Sun Mar 23 19:38:36 2008 @@ -158,6 +158,7 @@ (write-patchinfo patchinfo strout))) (write-byte 10 f))) +;; See also tests/gcau-tests.lisp (defun get-common-and-uncommon (ours theirs) "Given patchsets OURS and THEIRS, find common and uncommon patches. OURS and THEIRS are lists of lists of patchinfos, as returned by Added: cl-darcs/trunk/tests/gcau-tests.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/tests/gcau-tests.lisp Sun Mar 23 19:38:36 2008 @@ -0,0 +1,58 @@ +;;; Copyright (C) 2008 Magnus Henoch +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 2 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(in-package :darcs-tests) + +(def-suite get-common-and-uncommon-suite :in darcs-suite) +(in-suite get-common-and-uncommon-suite) + +(defun gen-patchinfo () + (darcs::make-patchinfo :name (format nil "~A" (random 1000)))) + +(defmacro tri-equal (form one two three) + `(multiple-value-bind (one two three) ,form + (is (equal ,one one)) + (is (equal ,two two)) + (is (equal ,three three)))) + +(test gcau-nil + (tri-equal (darcs::get-common-and-uncommon nil nil) + nil nil nil)) + +(test gcau-only-common + (for-all ((patchinfos (gen-list :elements #'gen-patchinfo))) + (tri-equal (darcs::get-common-and-uncommon (list patchinfos) (list patchinfos)) + patchinfos nil nil))) + +(test gcau-only-ours + (for-all ((patchinfos (gen-list :elements #'gen-patchinfo))) + (tri-equal (darcs::get-common-and-uncommon (list patchinfos) nil) + nil patchinfos nil))) + +(test gcau-only-theirs + (for-all ((patchinfos (gen-list :elements #'gen-patchinfo))) + (tri-equal (darcs::get-common-and-uncommon nil (list patchinfos)) + nil nil patchinfos))) + +(test gcau-both + (for-all ((common (gen-list :elements #'gen-patchinfo)) + (only-ours (gen-list :elements #'gen-patchinfo)) + (only-theirs (gen-list :elements #'gen-patchinfo))) + (let ((ours (list (append common only-ours))) + (theirs (list (append common only-theirs)))) + (tri-equal (darcs::get-common-and-uncommon ours theirs) + common only-ours only-theirs)))) + Added: cl-darcs/trunk/tests/package.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/tests/package.lisp Sun Mar 23 19:38:36 2008 @@ -0,0 +1,24 @@ +;;; Copyright (C) 2008 Magnus Henoch +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 2 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(defpackage :darcs-tests + (:use :cl :darcs :it.bese.FiveAM)) + +(in-package :darcs-tests) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (make-suite 'darcs-suite)) +

1 0

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

24 Mar '08

Author: mhenoch Date: Sun Mar 23 19:08:39 2008 New Revision: 178 Modified: cl-darcs/trunk/repo.lisp Log: GET-COMMON-AND-UNCOMMON returns patchinfo in correct order Modified: cl-darcs/trunk/repo.lisp ============================================================================== --- cl-darcs/trunk/repo.lisp (original) +++ cl-darcs/trunk/repo.lisp Sun Mar 23 19:08:39 2008 @@ -167,8 +167,16 @@ THEIRS." ;; Of course, there are possible optimizations here, in particular ;; regarding tags, but this will do for now. - (let ((ours-list (apply #'append (reverse ours))) - (theirs-list (apply #'append (reverse theirs)))) - (values (intersection ours-list theirs-list :test #'equalp) - (set-difference ours-list theirs-list :test #'equalp) - (set-difference theirs-list ours-list :test #'equalp)))) + (setf ours (apply #'append (reverse ours))) + (setf theirs (apply #'append (reverse theirs))) + (let (common-patches our-patches their-patches) + (loop + for ou on ours and th on theirs + while (equalp (car ou) (car th)) + collect (car ou) into common + finally + (setf common-patches common + our-patches ou + their-patches th)) + (values common-patches our-patches their-patches))) +

1 0

[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