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

[Cl-darcs-cvs] r37 - cl-darcs/trunk
by mhenoch＠common-lisp.net 01 Sep '06

01 Sep '06

Author: mhenoch Date: Thu Aug 31 20:21:43 2006 New Revision: 37 Added: cl-darcs/trunk/write-patch.lisp Log: Add write-patch Added: cl-darcs/trunk/write-patch.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/write-patch.lisp Thu Aug 31 20:21:43 2006 @@ -0,0 +1,145 @@ +;;; Copyright (C) 2006 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) + +(defun write-patch-to-repo (patch repo) + "Write the named patch PATCH to REPO, under correct filename." + (let ((filename + (upath-subdir repo '("_darcs" "patches") + (patchinfo-make-filename + (named-patch-patchinfo patch))))) + (with-open-file (out filename :direction :output :element-type '(unsigned-byte 8) + :if-exists :error) + (write-patch patch out)))) + +(defgeneric write-patch (patch stream) + (:documentation "Write PATCH to STREAM, in darcs patch format. +STREAM is assumed to have element type (unsigned-byte 8). +The patch is terminated by a newline character.")) + +(defun write-as-byte (char stream) + "Convert CHAR to a byte, and write it to STREAM." + (write-byte (char-code char) stream)) + +(defun write-as-bytes (string stream) + "Convert STRING to bytes, and write it to STREAM." + (write-sequence (string-to-bytes string) stream)) + +(defmethod write-patch ((patch composite-patch) stream) + (write-as-byte #\{ stream) + (dolist (part (patches patch)) + (write-patch part stream)) + (write-as-byte #\} stream) + (write-byte 10 stream)) + +(defmethod write-patch ((patch hunk-patch) stream) + (write-as-bytes (concatenate + 'string + "hunk " + (patch-filename patch) + (format nil " ~A" (hunk-line-number patch))) + stream) + (write-byte 10 stream) + (dolist (line (hunk-old-lines patch)) + (write-as-byte #\- stream) + (write-sequence line stream) + (write-byte 10 stream)) + (dolist (line (hunk-new-lines patch)) + (write-byte (char-code #\+) stream) + (write-sequence line stream) + (write-byte 10 stream))) + +(defun write-token-and-filename (token filename stream) + (write-as-bytes token stream) + (write-byte 32 stream) + (write-as-bytes filename stream) + (write-byte 10 stream)) + +(defmethod write-patch ((patch add-file-patch) stream) + (write-token-and-filename "addfile" (patch-filename patch) stream)) + +(defmethod write-patch ((patch rm-file-patch) stream) + (write-token-and-filename "rmfile" (patch-filename patch) stream)) + +(defmethod write-patch ((patch add-dir-patch) stream) + (write-token-and-filename "adddir" (patch-directory patch) stream)) + +(defmethod write-patch ((patch rm-dir-patch) stream) + (write-token-and-filename "rmdir" (patch-directory patch) stream)) + +(defmethod write-patch ((patch binary-patch) stream) + (write-token-and-filename "binary" (patch-filename patch) stream) + (flet ((write-binary-data (bin) + ;; Print binary data in hex format, with 78 characters per + ;; line. Each lines starts with *. A newline is printed + ;; at the start, but not at the end. + (loop for i from 0 upto (length bin) + do (when (zerop (mod i 49)) + (write-byte 10 stream) + (write-as-byte #\* stream)) + (write-as-bytes (string-downcase + (format nil "~X" (aref bin i))) + stream)))) + (write-as-bytes "oldhex" stream) + (write-binary-data (binary-oldhex patch)) + (write-as-bytes "newhex" stream) + (write-binary-data (binary-newhex patch)) + (write-byte 10 stream))) + +(defmethod write-patch ((patch token-replace-patch) stream) + (write-as-bytes (format nil "replace ~A [~A] ~A ~A" + (patch-filename patch) + (token-regexp patch) + (old-token patch) + (new-token patch)) + stream) + (write-byte 10 stream)) + +(defmethod write-patch ((patch named-patch) stream) + (write-as-bytes + (with-output-to-string (strout) + (write-patchinfo (named-patch-patchinfo patch) strout)) + stream) + (when (named-patch-dependencies patch) + (write-as-byte #\< stream) + (write-byte 10 stream) + (dolist (d (named-patch-dependencies patch)) + (write-as-bytes + (with-output-to-string (strout) + (write-patchinfo d strout)) + stream) + (write-byte 10 stream)) + (write-as-byte #\> stream) + (write-byte 32 stream)) + (write-patch (named-patch-patch patch) stream)) + +(defmethod write-patch ((patch change-pref-patch) stream) + (write-as-bytes "changepref " stream) + (write-as-bytes (change-pref-which patch) stream) + (write-byte 10 stream) + (write-sequence (change-pref-from patch) stream) + (write-byte 10 stream) + (write-sequence (change-pref-to patch) stream) + (write-byte 10 stream)) + +(defmethod write-patch ((patch move-patch) stream) + (write-sequence (string-to-bytes "move ") stream) + (write-sequence (string-to-bytes (patch-move-from patch)) stream) + (write-byte 32 stream) + (write-sequence (string-to-bytes (patch-move-to patch)) stream) + (write-byte 10 stream)) +

1 0

[Cl-darcs-cvs] r36 - cl-darcs/trunk
by mhenoch＠common-lisp.net 31 Aug '06

31 Aug '06

Author: mhenoch Date: Thu Aug 31 18:48:17 2006 New Revision: 36 Modified: cl-darcs/trunk/util.lisp Log: Add string-to-bytes, and explaining comment Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Thu Aug 31 18:48:17 2006 @@ -63,10 +63,16 @@ (atom (lambda (c) (eql c delimiters))) (list (lambda (c) (member c delimiters))))) +;; These two functions should be eachother's inverses, and be defined +;; for all possible 8-bit values. (defun bytes-to-string (sequence) "Convert SEQUENCE, a sequence of binary values, to a string." (map 'string #'code-char sequence)) +(defun string-to-bytes (string) + "Convert STRING to a vector of (unsigned-byte 8)." + (map '(vector (unsigned-byte 8)) #'char-code string)) + ;; These functions read vaguely character-like data from binary ;; streams.

1 0

[Cl-darcs-cvs] r35 - cl-darcs/trunk
by mhenoch＠common-lisp.net 31 Aug '06

31 Aug '06

Author: mhenoch Date: Thu Aug 31 09:09:18 2006 New Revision: 35 Modified: cl-darcs/trunk/get.lisp cl-darcs/trunk/pull.lisp cl-darcs/trunk/repo.lisp Log: Enable specifying which patches to get in get-repo, at the cost of not writing tag-based inventories. Modified: cl-darcs/trunk/get.lisp ============================================================================== --- cl-darcs/trunk/get.lisp (original) +++ cl-darcs/trunk/get.lisp Thu Aug 31 09:09:18 2006 @@ -41,50 +41,44 @@ (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) - (apply #'append (reverse patchinfo-list))))) + (let* ((all-patches (if checkpoint + ;; XXX: patchinfo-list is a list of lists now + (find-remaining-patches patchinfo-list checkpoint) + (apply #'append (reverse patchinfo-list)))) + (patches + (if (or (null query) (y-or-n-p "Apply all patches?")) + all-patches + (select-some-patches all-patches)))) + ;; write-inventory wants patches ordered by tags, but we have + ;;them all in a list in all-patches and patches... + ;;(write-inventory outname patchinfo-list) (copy-repo-patches repodir outname patches) - (if (or (null query) (y-or-n-p "Apply patches?")) - (progn - (format t "~&Applying patches") - (dolist (patch patches) - (apply-patch (read-patch-from-repo outname patch) - outname) - (format t "."))) - (format t "~&Not applying patches")) + (format t "~&Applying patches") + (dolist (patchinfo patches) + (let ((patch (read-patch-from-repo outname patchinfo))) + (apply-patch patch outname) + ;; XXX: this is where we write tags to inventory correctly + ;; Check how darcs handles tags - rotate inventory files? + ;; What happens when adding patches one by one? + (append-inventory outname patchinfo) + (format t "."))) (format t "~&All done")))) -(defun apply-some-patches (repo) - "Interactively select some patches to apply to REPO." - (setf repo (fad:pathname-as-directory repo)) - (let ((patch-files - (sort - (directory - (merge-pathnames - (make-pathname :directory (list :relative "_darcs" "patches") - :name :wild :type "gz") - repo)) - #'string< :key #'pathname-name))) - (format t "~&Available patches:") - (loop for file in patch-files - count file into i - do (format t "~&~3@A ~A" i (pathname-name file))) - (format t "~&Specify inclusive start and end (NIL will do): ") - (let ((start (read)) (end (read))) - (if start - (decf start) - (setf start 0)) - (let ((file-subset (subseq patch-files start end))) - (format t "~&Applying patches") - (dolist (patch-file file-subset) - (apply-patch (read-patch-from-file patch-file) repo) - (format t ".")) - (format t "~&Done"))))) +(defun select-some-patches (patchinfo-list) + "Interactively select some patches from PATCHINFO-LIST. +Return a new list containing the selected patches." + (format t "~&Available patches:") + (loop for patchinfo in patchinfo-list + count patchinfo into i + do (format t "~&~3@A ~A" i patchinfo)) + (format t "~&Specify inclusive start and end (NIL will do): ") + (let ((start (read)) (end (read))) + (if start + (decf start) + (setf start 0)) + (subseq patchinfo-list start end))) (defun find-remaining-patches (patchinfo-list checkpoint) "Find the patches remaining after getting to CHECKPOINT." Modified: cl-darcs/trunk/pull.lisp ============================================================================== --- cl-darcs/trunk/pull.lisp (original) +++ cl-darcs/trunk/pull.lisp Thu Aug 31 09:09:18 2006 @@ -34,7 +34,7 @@ (dolist (p only-theirs) (format t "~& - ~A" p)) ;; XXX: This is where we pick which of their patches we want to - ;; pull. + ;; pull. And copy them to our repo. (let* ((their-patches (mapcar (lambda (pi) (read-patch-from-repo theirrepo pi)) Modified: cl-darcs/trunk/repo.lisp ============================================================================== --- cl-darcs/trunk/repo.lisp (original) +++ cl-darcs/trunk/repo.lisp Thu Aug 31 09:09:18 2006 @@ -138,7 +138,9 @@ (make-pathname :directory '(:relative "_darcs") :name "inventory") outrepo) - :direction :output :if-exists :append + :direction :output + :if-exists :append + :if-does-not-exist :create :element-type '(unsigned-byte 8)) (map nil (lambda (char) (write-byte (char-code char) f))

1 0

[Cl-darcs-cvs] r34 - cl-darcs/trunk
by mhenoch＠common-lisp.net 15 Jul '06

15 Jul '06

Author: mhenoch Date: Sat Jul 15 07:40:12 2006 New Revision: 34 Modified: cl-darcs/trunk/pull.lisp Log: Use "defaultrepo" preference if no repo specified to pull from Modified: cl-darcs/trunk/pull.lisp ============================================================================== --- cl-darcs/trunk/pull.lisp (original) +++ cl-darcs/trunk/pull.lisp Sat Jul 15 07:40:12 2006 @@ -16,9 +16,15 @@ (in-package :darcs) -(defun pull (ourrepo theirrepo) - "Pull new patches from THEIRREPO into OURREPO." +(defun pull (ourrepo &optional theirrepo) + "Pull new patches from THEIRREPO into OURREPO. +If THEIRREPO is not specified, use default repositiory specified +in preferences." (setf ourrepo (fad:pathname-as-directory ourrepo)) + (unless theirrepo + (setf theirrepo (car (get-preflist ourrepo "defaultrepo"))) + (unless theirrepo + (error "No remote repositiory specified, and no default available."))) (let ((our-patchinfo (read-repo-patch-list ourrepo)) (their-patchinfo (read-repo-patch-list theirrepo))) (multiple-value-bind (common only-ours only-theirs)

1 0

[Cl-darcs-cvs] r33 - cl-darcs/trunk
by mhenoch＠common-lisp.net 15 Jul '06

15 Jul '06

Author: mhenoch Date: Sat Jul 15 07:33:00 2006 New Revision: 33 Modified: cl-darcs/trunk/cl-darcs.asd Log: Add pull.lisp to ASDF file Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Sat Jul 15 07:33:00 2006 @@ -29,6 +29,7 @@ (:file "patchinfo" :depends-on ("util")) (:file "get" :depends-on ("util")) + (:file "pull" :depends-on ("util")) (:file "init" :depends-on ("util")) (:file "prefs" :depends-on ("util")) (:file "repo" :depends-on ("util"))

1 0

[Cl-darcs-cvs] r32 - cl-darcs/trunk
by mhenoch＠common-lisp.net 14 Jul '06

14 Jul '06

Author: mhenoch Date: Fri Jul 14 19:47:25 2006 New Revision: 32 Added: cl-darcs/trunk/pull.lisp Log: Add pull.lisp Added: cl-darcs/trunk/pull.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/pull.lisp Fri Jul 14 19:47:25 2006 @@ -0,0 +1,52 @@ +;;; Copyright (C) 2006 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) + +(defun pull (ourrepo theirrepo) + "Pull new patches from THEIRREPO into OURREPO." + (setf ourrepo (fad:pathname-as-directory ourrepo)) + (let ((our-patchinfo (read-repo-patch-list ourrepo)) + (their-patchinfo (read-repo-patch-list theirrepo))) + (multiple-value-bind (common only-ours only-theirs) + (get-common-and-uncommon our-patchinfo their-patchinfo) + (declare (ignore common)) + (format t "~&Found these new patches:") + (dolist (p only-theirs) + (format t "~& - ~A" p)) + ;; XXX: This is where we pick which of their patches we want to + ;; pull. + (let* ((their-patches + (mapcar (lambda (pi) + (read-patch-from-repo theirrepo pi)) + only-theirs)) + (our-patches + (mapcar (lambda (pi) + (read-patch-from-repo ourrepo pi)) + only-ours)) + (merged-patches (patches + (merge-patches (make-instance 'composite-patch + :patches their-patches) + (make-instance 'composite-patch + :patches our-patches))))) + (format t "~&Applying patches") + (dolist (p merged-patches) + (apply-patch p ourrepo) + ;; If this is not a named patch, our assumptions are + ;; challenged. + (append-inventory ourrepo (named-patch-patchinfo p)) + (format t "."))))) + (format t "~&All done"))

1 0

[Cl-darcs-cvs] r31 - cl-darcs/trunk
by mhenoch＠common-lisp.net 14 Jul '06

14 Jul '06

Author: mhenoch Date: Fri Jul 14 19:47:12 2006 New Revision: 31 Modified: cl-darcs/trunk/repo.lisp Log: Add append-inventory function Modified: cl-darcs/trunk/repo.lisp ============================================================================== --- cl-darcs/trunk/repo.lisp (original) +++ cl-darcs/trunk/repo.lisp Fri Jul 14 19:47:12 2006 @@ -132,6 +132,20 @@ (write-byte 10 f) (print-patchinfos (car patchinfo-list))))))))) +(defun append-inventory (outrepo patchinfo) + "Append PATCHINFO to inventory in OUTREPO." + (with-open-file (f (merge-pathnames + (make-pathname :directory '(:relative "_darcs") + :name "inventory") + outrepo) + :direction :output :if-exists :append + :element-type '(unsigned-byte 8)) + (map nil (lambda (char) + (write-byte (char-code char) f)) + (with-output-to-string (strout) + (write-patchinfo patchinfo strout))) + (write-byte 10 f))) + (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

1 0

[Cl-darcs-cvs] r30 - cl-darcs/trunk
by mhenoch＠common-lisp.net 14 Jul '06

14 Jul '06

Author: mhenoch Date: Fri Jul 14 19:46:56 2006 New Revision: 30 Modified: cl-darcs/trunk/patchinfo.lisp Log: Add print-object method for patchinfo structures Modified: cl-darcs/trunk/patchinfo.lisp ============================================================================== --- cl-darcs/trunk/patchinfo.lisp (original) +++ cl-darcs/trunk/patchinfo.lisp Fri Jul 14 19:46:56 2006 @@ -116,3 +116,10 @@ (setf (patchinfo-inverted copy) (not (patchinfo-inverted copy))) copy)) + +(defmethod print-object ((patchinfo patchinfo) stream) + (if *print-readably* + (call-next-method) + (format stream "~A ~A (~A)" (patchinfo-date patchinfo) + (patchinfo-name patchinfo) + (patchinfo-author patchinfo))))

1 0

[Cl-darcs-cvs] r29 - cl-darcs/trunk
by mhenoch＠common-lisp.net 12 Jul '06

12 Jul '06

Author: mhenoch Date: Wed Jul 12 15:09:17 2006 New Revision: 29 Modified: cl-darcs/trunk/merge.lisp Log: Implement merge-patches-after-patch Modified: cl-darcs/trunk/merge.lisp ============================================================================== --- cl-darcs/trunk/merge.lisp (original) +++ cl-darcs/trunk/merge.lisp Wed Jul 12 15:09:17 2006 @@ -80,4 +80,9 @@ (defun merge-patches-after-patch (p1s p2) "Create a variant of P1S that can be applied after P2. P1S is a list of patches; P2 is a patch." - (error "merge-patches-after-patch not yet implemented.")) + (destructuring-bind (p1-new p2-new) + (commute (merge-patch-after-patches p2 p1s) + (make-instance 'composite-patch :patches p1s)) + (declare (ignore p2-new)) + (patches p1-new))) +

1 0

[Cl-darcs-cvs] r28 - cl-darcs/trunk
by mhenoch＠common-lisp.net 12 Jul '06

12 Jul '06

Author: mhenoch Date: Wed Jul 12 15:06:02 2006 New Revision: 28 Modified: cl-darcs/trunk/commute.lisp Log: Add commute methods for composite patches Modified: cl-darcs/trunk/commute.lisp ============================================================================== --- cl-darcs/trunk/commute.lisp (original) +++ cl-darcs/trunk/commute.lisp Wed Jul 12 15:06:02 2006 @@ -77,3 +77,44 @@ ;; In other cases, there is no failsafe way to commute the ;; patches, so we give up. nil))))) + +(defmethod commute ((p2 composite-patch) (p1 patch)) + (cond + ;; Simple case first... + ((null (patches p2)) + (list p1 p2)) + (t + ;; Now, p1 was committed before all the patches in p2, and we + ;; want it to come after. + (let ((p2s (patches p2)) + p2s-new) + (loop for p in p2s + do (destructuring-bind (&optional p1-new p-new) + (commute p p1) + (cond + ((null p1-new) + (return-from commute (call-next-method))) + (t + (setf p1 p1-new) + (push p-new p2s-new))))) + (list p1 (make-instance 'composite-patch :patches (nreverse p2s-new))))))) +(defmethod commute ((p2 patch) (p1 composite-patch)) + (cond + ((null (patches p1)) + (list p1 p2)) + (t + ;; p2 was committed after all the patches in p1. Thus we start + ;; backwards in p1, commuting p2 with each of the patches. + (let ((p1s (reverse (patches p1))) + p1s-new) + (loop for p in p1s + do (destructuring-bind (&optional p-new p2-new) + (commute p2 p) + (cond + ((null p-new) + (return-from commute (call-next-method))) + (t + (setf p2 p2-new) + (push p-new p1s-new))))) + (list (make-instance 'composite-patch :patches p1s-new) + p2)))))

1 0