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

[Cl-darcs-cvs] r187 - cl-darcs/trunk
by mhenoch＠common-lisp.net 01 Apr '08

01 Apr '08

Author: mhenoch Date: Tue Apr 1 18:37:24 2008 New Revision: 187 Modified: cl-darcs/trunk/cmdline.lisp Log: Generate documentation for all command arguments Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Tue Apr 1 18:37:24 2008 @@ -70,7 +70,7 @@ (defun command-usage (command) "Print longer documentation for COMMAND." - (format *error-output* "~&~A~%" (documentation (command-function command) 'function))) + (format *error-output* "~&~A~%" (get (command-function command) 'darcs-documentation))) (defmacro define-darcs-command (name options operands docstring &body body) "Define a darcs command called NAME. @@ -98,7 +98,35 @@ `(,o (cdr (assoc (option-keyword ,(option-symbol o)) ,options-sym)))) options) (destructuring-bind ,operands ,operands-sym - ,@body)))))))) + ,@body)))) + (setf (get ',function 'darcs-documentation) + ,(if (null options) + docstring + `(format nil + "~A~%~%~:{~A~30,5T~A~%~}" + ,docstring + (mapcar + (lambda (opt) + (list + (cond + ((and (option-short opt) + (option-long opt)) + (format nil "--~A~@[=~A~], -~C" + (option-long opt) + (option-arg opt) + (option-short opt))) + ((option-short opt) + (format nil "-~C~@[ ~A~]" + (option-short opt) + (option-arg opt))) + ((option-long opt) + (format nil "--~A~@[=~A~]" + (option-long opt) + (option-arg opt))) + (t + (error "Option ~A has neither short nor long argument form." (option-keyword opt)))) + (option-help opt))) + (list ,@(mapcar #'option-symbol options)))))))))) (defparameter opt-repodir (make-option

1 0

[Cl-darcs-cvs] r186 - cl-darcs/trunk
by mhenoch＠common-lisp.net 01 Apr '08

01 Apr '08

Author: mhenoch Date: Tue Apr 1 17:01:29 2008 New Revision: 186 Modified: cl-darcs/trunk/cmdline.lisp Log: "darcs get" Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Tue Apr 1 17:01:29 2008 @@ -324,6 +324,33 @@ ;; Change the default repository. (when (first from-repositories) - (set-default-repo ourrepo (upath-to-string (first from-repositories)))) + (set-default-repo ourrepo (upath-to-string (first from-repositories) :truename t))) 0)) + +(define-darcs-command get + (repodir) + (from) + "Get a copy of a repository." + (setf from (make-upath from)) + (let* ((to (or + ;; Either there is an explicit repodir... + repodir + ;; ...or we make one relative to the current directory. + (make-pathname + :directory + (list :relative + (typecase from + ;; If we have a local pathname, use the last component. + (pathname + (or (pathname-name pathname) + (car (last (pathname-directory pathname))))) + ;; Otherwise, use the part from the last slash. + (t + (let* ((s (upath-to-string from)) + (last-slash (position #\/ s :from-end t))) + (if last-slash + (subseq s (1+ last-slash)) + s))))))))) + (get-repo from to)) + 0)

1 0

[Cl-darcs-cvs] r185 - cl-darcs/trunk
by mhenoch＠common-lisp.net 01 Apr '08

01 Apr '08

Author: mhenoch Date: Tue Apr 1 17:01:01 2008 New Revision: 185 Modified: cl-darcs/trunk/get.lisp Log: GET-REPO: Use more truenames. Output same success message as darcs. Modified: cl-darcs/trunk/get.lisp ============================================================================== --- cl-darcs/trunk/get.lisp (original) +++ cl-darcs/trunk/get.lisp Tue Apr 1 17:01:01 2008 @@ -34,7 +34,7 @@ (setf outname (fad:pathname-as-directory outname)) ;; other access methods later... ;; XXX: checkpoints? - (let* ((repodir (make-upath inrepodir)) + (let* ((repodir (make-upath inrepodir :truename t)) ;; 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. @@ -48,6 +48,8 @@ ;; Create directories... (ensure-directories-exist outname) + ;; Now that the directory exists, we can get its truename + (setf outname (truename outname)) (prepare-new-repo outname) (set-default-repo outname (upath-to-string inrepodir :truename t)) @@ -85,7 +87,7 @@ (force-output))) (format t "~&Creating pristine") (create-pristine-from-tree outname) - (format t "~&All done")))) + (format t "~&Finished getting.")))) (defun select-some-patches (patchinfo-list) "Interactively select some patches from PATCHINFO-LIST.

1 0

[Cl-darcs-cvs] r184 - cl-darcs/trunk
by mhenoch＠common-lisp.net 01 Apr '08

01 Apr '08

Author: mhenoch Date: Tue Apr 1 17:00:17 2008 New Revision: 184 Modified: cl-darcs/trunk/upath.lisp Log: Add TRUENAME argument to MAKE-UPATH Modified: cl-darcs/trunk/upath.lisp ============================================================================== --- cl-darcs/trunk/upath.lisp (original) +++ cl-darcs/trunk/upath.lisp Tue Apr 1 17:00:17 2008 @@ -20,14 +20,18 @@ ;; file. For local files, just use pathnames. For remote files, use ;; the PURI library. (Or the real thing, if we're using ACL) -(defun make-upath (path) +(defun make-upath (path &key truename) "Turn PATH into a \"universal pathname\". If PATH is a pathname or URI, return it unchanged. If PATH starts with \"http://\" or \"https://\", return a URI. -Else, return a pathname." +Else, return a pathname. + +If TRUENAME is provided and true, give an absolute path." (ctypecase path (pathname - path) + (if truename + (truename path) + path)) (net.uri:uri path) (string @@ -36,7 +40,9 @@ (and (>= (length path) 8) (string= path "https://" :end1 8))) (net.uri:parse-uri path) - (pathname path))))) + (if truename + (truename (pathname path)) + (pathname path)))))) (defun upath-subdir (base subdirs &optional filename) "From BASE, descend into SUBDIRS and FILENAME.

1 0

[Cl-darcs-cvs] r183 - cl-darcs/trunk
by mhenoch＠common-lisp.net 01 Apr '08

01 Apr '08

Author: mhenoch Date: Tue Apr 1 16:45:39 2008 New Revision: 183 Modified: cl-darcs/trunk/get.lisp Log: Fix order of parentheses Modified: cl-darcs/trunk/get.lisp ============================================================================== --- cl-darcs/trunk/get.lisp (original) +++ cl-darcs/trunk/get.lisp Tue Apr 1 16:45:39 2008 @@ -49,7 +49,7 @@ ;; Create directories... (ensure-directories-exist outname) (prepare-new-repo outname) - (set-default-repo outname (upath-to-string inrepodir) :truename t) + (set-default-repo outname (upath-to-string inrepodir :truename t)) (when checkpoint (format t "~&Copying checkpoint...")

1 0

[Cl-darcs-cvs] r182 - cl-darcs/trunk
by mhenoch＠common-lisp.net 01 Apr '08

01 Apr '08

Author: mhenoch Date: Tue Apr 1 16:34:10 2008 New Revision: 182 Modified: cl-darcs/trunk/get.lisp cl-darcs/trunk/upath.lisp Log: Add TRUENAME argument to UPATH-TO-STRING, and use it in GET-REPO Modified: cl-darcs/trunk/get.lisp ============================================================================== --- cl-darcs/trunk/get.lisp (original) +++ cl-darcs/trunk/get.lisp Tue Apr 1 16:34:10 2008 @@ -49,7 +49,7 @@ ;; Create directories... (ensure-directories-exist outname) (prepare-new-repo outname) - (set-default-repo outname inrepodir) + (set-default-repo outname (upath-to-string inrepodir) :truename t) (when checkpoint (format t "~&Copying checkpoint...") Modified: cl-darcs/trunk/upath.lisp ============================================================================== --- cl-darcs/trunk/upath.lisp (original) +++ cl-darcs/trunk/upath.lisp Tue Apr 1 16:34:10 2008 @@ -83,14 +83,17 @@ (open upath :direction :input :if-does-not-exist :error :element-type (if binary '(unsigned-byte 8) 'character))))) -(defun upath-to-string (upath) +(defun upath-to-string (upath &key truename) "Convert UPATH to a string. -This string can be read with MAKE-UPATH." +This string can be read with MAKE-UPATH. +When TRUENAME is provided and true, give absolute/canonical form." (ctypecase upath (string upath) (pathname - (namestring upath)) + (namestring (if truename + (truename upath) + upath))) (net.uri:uri (with-output-to-string (s) (net.uri:render-uri upath s)))))

1 0

[Cl-darcs-cvs] r181 - cl-darcs/trunk
by mhenoch＠common-lisp.net 01 Apr '08

01 Apr '08

Author: mhenoch Date: Tue Apr 1 16:26:32 2008 New Revision: 181 Modified: cl-darcs/trunk/upath.lisp Log: Fix MAKE-UPATH for short arguments Modified: cl-darcs/trunk/upath.lisp ============================================================================== --- cl-darcs/trunk/upath.lisp (original) +++ cl-darcs/trunk/upath.lisp Tue Apr 1 16:26:32 2008 @@ -31,8 +31,10 @@ (net.uri:uri path) (string - (if (or (string= path "http://" :end1 7) - (string= path "https://" :end1 8)) + (if (or (and (>= (length path) 7) + (string= path "http://" :end1 7)) + (and (>= (length path) 8) + (string= path "https://" :end1 8))) (net.uri:parse-uri path) (pathname path)))))

1 0

[Cl-darcs-cvs] r180 - cl-darcs/trunk
by mhenoch＠common-lisp.net 01 Apr '08

01 Apr '08

Author: mhenoch Date: Tue Apr 1 16:12:14 2008 New Revision: 180 Added: cl-darcs/trunk/Makefile (contents, props changed) Log: Add basic Makefile Added: cl-darcs/trunk/Makefile ============================================================================== --- (empty file) +++ cl-darcs/trunk/Makefile Tue Apr 1 16:12:14 2008 @@ -0,0 +1,14 @@ +CLISP ?= clisp +CLISP_OPTIONS ?= -i $(HOME)/.clisprc +SBCL ?= sbcl +SBCL_OPTIONS ?= --disable-debugger + +any: + @echo Use either \"$(MAKE) clisp\" or \"$(MAKE) sbcl\". + @false + +clisp: + $(CLISP) $(CLISP_OPTIONS) dump-clisp.lisp + +sbcl: + $(SBCL) $(SBCL_OPTIONS) --load dump-sbcl.lisp

1 0

[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