From mhenoch at common-lisp.net Fri Sep 1 00:21:43 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Thu, 31 Aug 2006 20:21:43 -0400 (EDT) Subject: [Cl-darcs-cvs] r37 - cl-darcs/trunk Message-ID: <20060901002143.CC1401D102@common-lisp.net> 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)) + From mhenoch at common-lisp.net Fri Sep 1 00:22:13 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Thu, 31 Aug 2006 20:22:13 -0400 (EDT) Subject: [Cl-darcs-cvs] r38 - cl-darcs/trunk Message-ID: <20060901002213.AA99C1D0C0@common-lisp.net> Author: mhenoch Date: Thu Aug 31 20:22:13 2006 New Revision: 38 Modified: cl-darcs/trunk/pull.lisp Log: Use write-patch-to-repo when pulling Modified: cl-darcs/trunk/pull.lisp ============================================================================== --- cl-darcs/trunk/pull.lisp (original) +++ cl-darcs/trunk/pull.lisp Thu Aug 31 20:22:13 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. And copy them to our repo. + ;; pull. (let* ((their-patches (mapcar (lambda (pi) (read-patch-from-repo theirrepo pi)) @@ -54,5 +54,6 @@ ;; If this is not a named patch, our assumptions are ;; challenged. (append-inventory ourrepo (named-patch-patchinfo p)) + (write-patch-to-repo p ourrepo) (format t "."))))) (format t "~&All done")) From mhenoch at common-lisp.net Fri Sep 1 00:22:35 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Thu, 31 Aug 2006 20:22:35 -0400 (EDT) Subject: [Cl-darcs-cvs] r39 - cl-darcs/trunk Message-ID: <20060901002235.8FAF71D0C0@common-lisp.net> Author: mhenoch Date: Thu Aug 31 20:22:35 2006 New Revision: 39 Modified: cl-darcs/trunk/apply-patch.lisp Log: Make binary patch non-match a continuable error Modified: cl-darcs/trunk/apply-patch.lisp ============================================================================== --- cl-darcs/trunk/apply-patch.lisp (original) +++ cl-darcs/trunk/apply-patch.lisp Thu Aug 31 20:22:35 2006 @@ -120,7 +120,8 @@ :element-type '(unsigned-byte 8)))) (read-sequence bytes in) (not (equalp bytes (binary-oldhex patch))))) - (error "Contents of ~A don't match patch." file))) + (cerror "Write new contents to ~A anyway." + "Contents of ~A don't match patch." file))) ;; Overwrite with new content. (with-open-file (out file :direction :output :if-exists :supersede From mhenoch at common-lisp.net Fri Sep 1 09:48:01 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Fri, 1 Sep 2006 05:48:01 -0400 (EDT) Subject: [Cl-darcs-cvs] r40 - cl-darcs/trunk Message-ID: <20060901094801.D80982401E@common-lisp.net> Author: mhenoch Date: Fri Sep 1 05:48:01 2006 New Revision: 40 Modified: cl-darcs/trunk/README Log: Update README Modified: cl-darcs/trunk/README ============================================================================== --- cl-darcs/trunk/README (original) +++ cl-darcs/trunk/README Fri Sep 1 05:48:01 2006 @@ -15,9 +15,11 @@ Or if you want to select which patches to apply: (get-repo "http://path/to/repo" "/local/repo-dir/" :query t) -(apply-some-patches "/local/repo-dir/") -That's all that is implemented so far. +To pull new patches from a repo (the address from the remote repo is +optional, as it defaults to where you got the tree from): + +(pull "/local/repo-dir/" "http://path/to/repo") * Compatibility From mhenoch at common-lisp.net Sat Sep 2 11:18:47 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Sat, 2 Sep 2006 07:18:47 -0400 (EDT) Subject: [Cl-darcs-cvs] r41 - cl-darcs/trunk Message-ID: <20060902111847.78A9F5401F@common-lisp.net> Author: mhenoch Date: Sat Sep 2 07:18:46 2006 New Revision: 41 Modified: cl-darcs/trunk/packages.lisp Log: Export GET-REPO and PULL Modified: cl-darcs/trunk/packages.lisp ============================================================================== --- cl-darcs/trunk/packages.lisp (original) +++ cl-darcs/trunk/packages.lisp Sat Sep 2 07:18:46 2006 @@ -4,4 +4,4 @@ (:use :cl) (:nicknames :cl-darcs) (:export - )) + #:get-repo #:pull)) From mhenoch at common-lisp.net Sat Sep 2 12:09:40 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Sat, 2 Sep 2006 08:09:40 -0400 (EDT) Subject: [Cl-darcs-cvs] r42 - cl-darcs/trunk Message-ID: <20060902120940.248E17434F@common-lisp.net> Author: mhenoch Date: Sat Sep 2 08:09:39 2006 New Revision: 42 Modified: cl-darcs/trunk/packages.lisp Log: Export *HTTP-PROXY* Modified: cl-darcs/trunk/packages.lisp ============================================================================== --- cl-darcs/trunk/packages.lisp (original) +++ cl-darcs/trunk/packages.lisp Sat Sep 2 08:09:39 2006 @@ -4,4 +4,4 @@ (:use :cl) (:nicknames :cl-darcs) (:export - #:get-repo #:pull)) + #:get-repo #:pull #:*http-proxy*))