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

[Cl-darcs-cvs] r117 - cl-darcs/trunk
by mhenoch＠common-lisp.net 30 Mar '07

30 Mar '07

Author: mhenoch Date: Fri Mar 30 08:15:59 2007 New Revision: 117 Modified: cl-darcs/trunk/send.lisp Log: Don't cut history after latest tag if there is no tag Modified: cl-darcs/trunk/send.lisp ============================================================================== --- cl-darcs/trunk/send.lisp (original) +++ cl-darcs/trunk/send.lisp Fri Mar 30 08:15:59 2007 @@ -81,9 +81,10 @@ (string= (patchinfo-name patchinfo) "TAG " :end1 4)) common))) - ;; Here we just cut history after the latest tag. This - ;; should work in most cases. - (setf (cdr latest-tag) nil)) + (when latest-tag + ;; Here we just cut history after the latest tag. This + ;; should work in most cases. + (setf (cdr latest-tag) nil))) (dolist (patchinfo common) (write-sequence (string-to-bytes

1 0

[Cl-darcs-cvs] r116 - cl-darcs/trunk
by mhenoch＠common-lisp.net 30 Mar '07

30 Mar '07

Author: mhenoch Date: Fri Mar 30 08:14:33 2007 New Revision: 116 Modified: cl-darcs/trunk/send.lisp Log: Don't use PI as variable in lambda function Modified: cl-darcs/trunk/send.lisp ============================================================================== --- cl-darcs/trunk/send.lisp (original) +++ cl-darcs/trunk/send.lisp Fri Mar 30 08:14:33 2007 @@ -77,8 +77,8 @@ ;; XXX: handle tags properly. (let ((latest-tag (member-if - (lambda (pi) - (string= (patchinfo-name pi) "TAG " + (lambda (patchinfo) + (string= (patchinfo-name patchinfo) "TAG " :end1 4)) common))) ;; Here we just cut history after the latest tag. This

1 0

[Cl-darcs-cvs] r115 - cl-darcs/trunk
by mhenoch＠common-lisp.net 16 Mar '07

16 Mar '07

Author: mhenoch Date: Thu Mar 15 22:22:39 2007 New Revision: 115 Modified: cl-darcs/trunk/revert.lisp Log: Only print "Reapplying" when actually reapplying something Modified: cl-darcs/trunk/revert.lisp ============================================================================== --- cl-darcs/trunk/revert.lisp (original) +++ cl-darcs/trunk/revert.lisp Thu Mar 15 22:22:39 2007 @@ -45,10 +45,11 @@ (princ #\.) (force-output)) - ;; Then reapply all patches we want to keep - (format t "~&Reapplying") - (dolist (patch patches-to-keep) - (apply-patch patch repo) - (princ #\.) - (force-output)))) + (when patches-to-keep + ;; Then reapply all patches we want to keep + (format t "~&Reapplying") + (dolist (patch patches-to-keep) + (apply-patch patch repo) + (princ #\.) + (force-output)))))

1 0

[Cl-darcs-cvs] r114 - cl-darcs/trunk
by mhenoch＠common-lisp.net 16 Mar '07

16 Mar '07

Author: mhenoch Date: Thu Mar 15 22:19:21 2007 New Revision: 114 Modified: cl-darcs/trunk/commute.lisp Log: Add COMMUTE methods for trivial commutations of FILE-PATCH and MERGER-PATCH. Modified: cl-darcs/trunk/commute.lisp ============================================================================== --- cl-darcs/trunk/commute.lisp (original) +++ cl-darcs/trunk/commute.lisp Thu Mar 15 22:19:21 2007 @@ -97,6 +97,30 @@ (list p1 p2) (call-next-method)))) +(defmethod commute :around ((p2 file-patch) (p1 merger-patch)) + "If P1 touches only one file, and P2 touches another, commutation is trivial." + (let ((p1-first (merger-first p1)) + (p1-second (merger-second p1)) + (p2-file (patch-filename p2))) + (if (and (typep p1-first 'file-patch) + (typep p1-second 'file-patch) + (equal (patch-filename p1-first) (patch-filename p1-second)) + (not (equal (patch-filename p1-first) p2-file))) + (list p1 p2) + (call-next-method)))) + +(defmethod commute :around ((p2 merger-patch) (p1 file-patch)) + "If P2 touches only one file, and P1 touches another, commutation is trivial." + (let ((p1-file (patch-filename p1)) + (p2-first (merger-first p2)) + (p2-second (merger-second p2))) + (if (and (typep p2-first 'file-patch) + (typep p2-second 'file-patch) + (equal (patch-filename p2-first) (patch-filename p2-second)) + (not (equal (patch-filename p2-first) p1-file))) + (list p1 p2) + (call-next-method)))) + (defmethod commute ((p2 hunk-patch) (p1 hunk-patch)) "Attempt to commute the two hunk patches P1 and P2." (assert (equal (patch-filename p1) (patch-filename p2)))

1 0

[Cl-darcs-cvs] r113 - cl-darcs/trunk
by mhenoch＠common-lisp.net 16 Mar '07

16 Mar '07

Author: mhenoch Date: Thu Mar 15 21:48:22 2007 New Revision: 113 Modified: cl-darcs/trunk/packages.lisp Log: Export REVERT-CHANGES and SEND-TO-FILE Modified: cl-darcs/trunk/packages.lisp ============================================================================== --- cl-darcs/trunk/packages.lisp (original) +++ cl-darcs/trunk/packages.lisp Thu Mar 15 21:48:22 2007 @@ -6,4 +6,5 @@ (:export #:*http-proxy* #:get-repo #:pull #:diff-repo #:diff-repo-display - #:record-changes #:create-repo)) + #:record-changes #:create-repo + #:revert-changes #:send-to-file))

1 0

[Cl-darcs-cvs] r112 - cl-darcs/trunk
by mhenoch＠common-lisp.net 16 Mar '07

16 Mar '07

Author: mhenoch Date: Thu Mar 15 21:47:47 2007 New Revision: 112 Added: cl-darcs/trunk/revert.lisp Modified: cl-darcs/trunk/cl-darcs.asd Log: Add revert.lisp and REVERT-CHANGES Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Thu Mar 15 21:47:47 2007 @@ -54,6 +54,7 @@ (:file "unwind" :depends-on ("patch-core")) (:file "equal" :depends-on ("patch-core")) (:file "send" :depends-on ("patch-core")) + (:file "revert" :depends-on ("patch-core")) ;; Franz' inflate implementation #-allegro (:file "ifstar") Added: cl-darcs/trunk/revert.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/revert.lisp Thu Mar 15 21:47:47 2007 @@ -0,0 +1,54 @@ +;;; Copyright (C) 2007 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 revert-changes (repo &key (select-patches :ask)) + "Revert unrecorded changes in REPO. +SELECT-PATCHES specifies how to select which patches to revert. +It can be one of: +:ALL - revert all patches +:ASK - ask for each patch through Y-OR-N-P +a function - call this function with a PATCH object, and + revert if it returns true" + (setf repo (fad:pathname-as-directory repo)) + + (let* ((patches (diff-repo repo)) + (patches-to-keep + (if (eql select-patches :all) + nil + (select-patches (copy-seq patches) + ;; here the sense of the predicate is + ;; inverted. + (case select-patches + (:ask (lambda (p) + (display-patch p *query-io*) + (not (y-or-n-p "Revert this patch?")))) + (t (complement select-patches))))))) + ;; First revert all patches + (format t "~&Reverting") + (dolist (patch (reverse (mapcar #'invert-patch patches))) + (apply-patch patch repo) + (princ #\.) + (force-output)) + + ;; Then reapply all patches we want to keep + (format t "~&Reapplying") + (dolist (patch patches-to-keep) + (apply-patch patch repo) + (princ #\.) + (force-output)))) +

1 0

[Cl-darcs-cvs] r111 - cl-darcs/trunk
by mhenoch＠common-lisp.net 15 Mar '07

15 Mar '07

Author: mhenoch Date: Thu Mar 15 17:27:17 2007 New Revision: 111 Added: cl-darcs/trunk/send.lisp Modified: cl-darcs/trunk/cl-darcs.asd Log: Add send-to-file Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Thu Mar 15 17:27:17 2007 @@ -16,6 +16,7 @@ :trivial-gray-streams ;; SHA1, hex etc :ironclad + :flexi-streams ;; Ironclad's SHA1 doesn't work with CLISP yet #+clisp :sb-sha1 ;; Files and directories @@ -52,6 +53,7 @@ (:file "merge" :depends-on ("patch-core")) (:file "unwind" :depends-on ("patch-core")) (:file "equal" :depends-on ("patch-core")) + (:file "send" :depends-on ("patch-core")) ;; Franz' inflate implementation #-allegro (:file "ifstar") Added: cl-darcs/trunk/send.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/send.lisp Thu Mar 15 17:27:17 2007 @@ -0,0 +1,108 @@ +;;; Copyright (C) 2007 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 send-to-file (our-repo file &key their-repo (select-patches :ask)) + "Write new patches in OUR-REPO to FILE, suitable for sending by e-mail. +\"New\" patches are those present in OUR-REPO but not in +THEIR-REPO. If THEIR-REPO is NIL, use default repository +specified in preferences. +SELECT-PATCHES specifies how to select which patches to include. +It can be one of: +:ALL - include all patches +:ASK - ask for each patch through Y-OR-N-P +a function - call this function with a NAMED-PATCH object, and + include if it returns true" + (setf our-repo (fad:pathname-as-directory our-repo)) + (unless their-repo + (unless (setf their-repo (car (get-preflist our-repo "defaultrepo"))) + (error "No remote repositiory specified, and no default available."))) + + (with-open-file (f file + :direction :output + :element-type '(unsigned-byte 8)) + + (let ((our-patchinfo (read-repo-patch-list our-repo)) + (their-patchinfo (read-repo-patch-list their-repo))) + (multiple-value-bind (common only-ours only-theirs) + (get-common-and-uncommon our-patchinfo their-patchinfo) + (declare (ignore only-theirs)) + (format t "~&Found these new patches:") + (dolist (p only-ours) + (format t "~& - ~A" p)) + + (let* ((all-our-patches + (mapcar (lambda (patchinfo) + (read-patch-from-repo our-repo patchinfo)) + only-ours)) + (patches-to-send + (if (or (eq select-patches :all) + (and (eq select-patches :ask) + (y-or-n-p "Send all patches?"))) + all-our-patches + (select-patches all-our-patches + (if (functionp select-patches) + select-patches + (lambda (patch) + (display-patch patch *query-io*) + (y-or-n-p "Include patch ~A? " patch))))))) + + (write-byte 10 f) + (write-sequence (string-to-bytes "New patches:") f) + (write-byte 10 f) + (write-byte 10 f) + (dolist (patch patches-to-send) + (write-patch patch f)) + (write-byte 10 f) + + (write-sequence (string-to-bytes "Context:") f) + (write-byte 10 f) + (write-byte 10 f) + ;; Context is in reverse order: latest applied first. + (setf common (nreverse common)) + + ;; XXX: handle tags properly. + (let ((latest-tag (member-if + (lambda (pi) + (string= (patchinfo-name pi) "TAG " + :end1 4)) + common))) + ;; Here we just cut history after the latest tag. This + ;; should work in most cases. + (setf (cdr latest-tag) nil)) + + (dolist (patchinfo common) + (write-sequence (string-to-bytes + (with-output-to-string (strout) + (write-patchinfo patchinfo strout))) + f) + (write-byte 10 f)) + (write-sequence (string-to-bytes "Patch bundle hash:") f) + (write-byte 10 f) + (write-sequence (string-to-bytes (hash-bundle patches-to-send)) f) + (write-byte 10 f)))))) + +(defun hash-bundle (patches) + (let ((patches-as-vector + (flexi-streams:with-output-to-sequence (out) + (dolist (patch patches) + (write-patch patch out))))) + (setf patches-as-vector + (coerce patches-as-vector '(simple-array (unsigned-byte 8)))) + (ironclad:byte-array-to-hex-string + #+clisp (sb-sha1:sha1sum-sequence patches-as-vector) + #-clisp (ironclad:digest-sequence :sha1 patches-as-vector))))

1 0

[Cl-darcs-cvs] r110 - cl-darcs/trunk
by mhenoch＠common-lisp.net 15 Mar '07

15 Mar '07

Author: mhenoch Date: Thu Mar 15 16:41:55 2007 New Revision: 110 Modified: cl-darcs/trunk/repo.lisp Log: Fix thinko in get-common-and-uncommon Modified: cl-darcs/trunk/repo.lisp ============================================================================== --- cl-darcs/trunk/repo.lisp (original) +++ cl-darcs/trunk/repo.lisp Thu Mar 15 16:41:55 2007 @@ -159,6 +159,6 @@ ;; regarding tags, but this will do for now. (let ((ours-list (apply #'append (reverse ours))) (theirs-list (apply #'append (reverse theirs)))) - (values (union ours-list theirs-list :test #'equalp) + (values (intersection ours-list theirs-list :test #'equalp) (set-difference ours-list theirs-list :test #'equalp) (set-difference theirs-list ours-list :test #'equalp))))

1 0

[Cl-darcs-cvs] r109 - cl-darcs/trunk
by mhenoch＠common-lisp.net 13 Mar '07

13 Mar '07

Author: mhenoch Date: Mon Mar 12 23:14:00 2007 New Revision: 109 Modified: cl-darcs/trunk/cl-darcs.asd Log: Fix dependency problem for record.lisp Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Mon Mar 12 23:14:00 2007 @@ -38,9 +38,9 @@ (:file "prefs" :depends-on ("util")) (:file "repo" :depends-on ("util")) (:file "diff" :depends-on ("util")) - (:file "record" :depends-on ("util")) (:file "patch-core" :depends-on ("util")) + (:file "record" :depends-on ("patch-core")) (:file "read-patch" :depends-on ("patch-core")) (:file "write-patch" :depends-on ("patch-core")) (:file "apply-patch" :depends-on ("patch-core"))

1 0

[Cl-darcs-cvs] r108 - cl-darcs/trunk
by mhenoch＠common-lisp.net 11 Mar '07

11 Mar '07

Author: mhenoch Date: Sat Mar 10 22:14:51 2007 New Revision: 108 Modified: cl-darcs/trunk/get.lisp cl-darcs/trunk/pull.lisp Log: Flush *STANDARD-OUTPUT* when writing progress dots Modified: cl-darcs/trunk/get.lisp ============================================================================== --- cl-darcs/trunk/get.lisp (original) +++ cl-darcs/trunk/get.lisp Sat Mar 10 22:14:51 2007 @@ -73,7 +73,8 @@ ;; Check how darcs handles tags - rotate inventory files? ;; What happens when adding patches one by one? (append-inventory outname patchinfo) - (format t "."))) + (princ #\.) + (force-output))) (format t "~&Creating pristine") (create-pristine-from-tree outname) (format t "~&All done")))) @@ -115,7 +116,8 @@ (upath-subdir from '("_darcs" "patches") filename) :binary t)) (fad:copy-stream in out)))) - (princ #\.))) + (princ #\.) + (force-output))) (defun copy-checkpoint (from to checkpoint) "Copy CHECKPOINT from repository FROM to repository TO. Modified: cl-darcs/trunk/pull.lisp ============================================================================== --- cl-darcs/trunk/pull.lisp (original) +++ cl-darcs/trunk/pull.lisp Sat Mar 10 22:14:51 2007 @@ -92,7 +92,8 @@ :report "Stop trying to apply patches to the source tree (they will be applied to the pristine tree)" (setf source-and-pristine-differ t) (setf applying-to-source nil)))) - (format t ".")) + (princ #\.) + (force-output)) (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)))))

1 0