October 2006 - cl-darcs-cvs@lists.common-lisp.net

[Cl-darcs-cvs] r51 - cl-darcs/trunk
by mhenoch＠common-lisp.net 06 Oct '06

06 Oct '06

Author: mhenoch Date: Fri Oct 6 15:55:15 2006 New Revision: 51 Added: cl-darcs/trunk/pristine.lisp Modified: cl-darcs/trunk/get.lisp cl-darcs/trunk/pull.lisp Log: Add functions for keeping a pristine. Use it when getting and pulling. Modified: cl-darcs/trunk/get.lisp ============================================================================== --- cl-darcs/trunk/get.lisp (original) +++ cl-darcs/trunk/get.lisp Fri Oct 6 15:55:15 2006 @@ -64,6 +64,8 @@ ;; What happens when adding patches one by one? (append-inventory outname patchinfo) (format t "."))) + (format t "~&Creating pristine") + (create-pristine-from-tree outname) (format t "~&All done")))) (defun select-some-patches (patchinfo-list) Added: cl-darcs/trunk/pristine.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/pristine.lisp Fri Oct 6 15:55:15 2006 @@ -0,0 +1,28 @@ +;;; 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 create-pristine-from-tree (repodir) + "Copy the checked-out tree at REPODIR to get a pristine tree." + (let* ((darcs-dir (upath-subdir repodir '("_darcs"))) + (pristine-dir (upath-subdir darcs-dir '("pristine")))) + (make-dir pristine-dir) + (copy-directory repodir pristine-dir :excluding (list darcs-dir)))) + +(defun apply-patch-to-pristine (patch repodir) + "Apply PATCH to the pristine tree in REPODIR." + (apply-patch patch (upath-subdir repodir '("_darcs" "pristine")))) Modified: cl-darcs/trunk/pull.lisp ============================================================================== --- cl-darcs/trunk/pull.lisp (original) +++ cl-darcs/trunk/pull.lisp Fri Oct 6 15:55:15 2006 @@ -49,11 +49,32 @@ (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)) - (write-patch-to-repo p ourrepo) - (format t "."))))) - (format t "~&All done")) + (let ((applying-to-source t) + (source-and-pristine-differ nil)) + (dolist (p merged-patches) + ;; First, copy the modified patch to the repository. + (write-patch-to-repo p ourrepo) + ;; Then, apply it to the pristine copy. This couldn't + ;; possibly fail. + (apply-patch-to-pristine p ourrepo) + ;; Note the patch in the inventory. + (append-inventory ourrepo (named-patch-patchinfo p)) + ;; And finally apply the patch to the real source. This + ;; could fail if the source has been modified. Deal with + ;; that in a crude way. XXX: it is wasteful to apply + ;; patches twice. + (when applying-to-source + (restart-case + (apply-patch p ourrepo) + (skip-this () + :report "Don't apply this patch to the source tree (it was applied to the pristine tree)" + (setf source-and-pristine-differ t)) + (skip-all () + :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 ".")) + (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/.~:@>"))))) + (format t "~&All done")))

1 0

[Cl-darcs-cvs] r50 - cl-darcs/trunk
by mhenoch＠common-lisp.net 06 Oct '06

06 Oct '06

Author: mhenoch Date: Fri Oct 6 15:50:49 2006 New Revision: 50 Modified: cl-darcs/trunk/cl-darcs.asd Log: Load write-patch.lisp in ASDF file Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Fri Oct 6 15:50:49 2006 @@ -36,6 +36,7 @@ (:file "patch-core" :depends-on ("util")) (:file "read-patch" :depends-on ("patch-core")) + (:file "write-patch" :depends-on ("patch-core")) (:file "apply-patch" :depends-on ("patch-core")) (:file "invert-patch" :depends-on ("patch-core")) (:file "touching" :depends-on ("patch-core"))

1 0

[Cl-darcs-cvs] r49 - cl-darcs/trunk
by mhenoch＠common-lisp.net 06 Oct '06

06 Oct '06

Author: mhenoch Date: Fri Oct 6 15:50:11 2006 New Revision: 49 Modified: cl-darcs/trunk/write-patch.lisp Log: Write newline after { when writing composite patches Modified: cl-darcs/trunk/write-patch.lisp ============================================================================== --- cl-darcs/trunk/write-patch.lisp (original) +++ cl-darcs/trunk/write-patch.lisp Fri Oct 6 15:50:11 2006 @@ -43,6 +43,7 @@ (defmethod write-patch ((patch composite-patch) stream) (write-as-byte #\{ stream) + (write-byte 10 stream) (dolist (part (patches patch)) (write-patch part stream)) (write-as-byte #\} stream)

1 0

[Cl-darcs-cvs] r48 - cl-darcs/trunk
by mhenoch＠common-lisp.net 06 Oct '06

06 Oct '06

Author: mhenoch Date: Fri Oct 6 15:49:46 2006 New Revision: 48 Modified: cl-darcs/trunk/write-patch.lisp Log: Use compress-file in write-patch-to-repo Modified: cl-darcs/trunk/write-patch.lisp ============================================================================== --- cl-darcs/trunk/write-patch.lisp (original) +++ cl-darcs/trunk/write-patch.lisp Fri Oct 6 15:49:46 2006 @@ -17,14 +17,16 @@ (in-package :darcs) (defun write-patch-to-repo (patch repo) - "Write the named patch PATCH to REPO, under correct filename." + "Write the named patch PATCH to REPO, compressed, 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)))) + (with-temp-file-name tmp-file + (with-open-file (out tmp-file :direction :output :element-type '(unsigned-byte 8) + :if-exists :error) + (write-patch patch out)) + (compress-file tmp-file filename)))) (defgeneric write-patch (patch stream) (:documentation "Write PATCH to STREAM, in darcs patch format.

1 0

[Cl-darcs-cvs] r47 - cl-darcs/trunk
by mhenoch＠common-lisp.net 06 Oct '06

06 Oct '06

Author: mhenoch Date: Fri Oct 6 15:49:24 2006 New Revision: 47 Modified: cl-darcs/trunk/util.lisp Log: Add compress-file function Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Fri Oct 6 15:49:24 2006 @@ -140,6 +140,20 @@ (util.zip:inflate in out) (dformat "done")))))) +(defun compress-file (infile outfile) + "Compress INFILE and write contents to OUTFILE." + (setf infile (make-upath infile)) + (cond + #+clisp + ((pathnamep infile) + (dformat "~&Compressing ~A through external program..." outfile) + (ext:run-program "gzip" :input (namestring infile) :output (namestring outfile) + :if-output-exists :error) + (dformat "done")) + (t + (cerror "Assume compression performed." + "Don't know how to gzip ~A to ~A." infile outfile)))) + (defun make-temp-file-name () "Create a random name for a temporary file. This is hopefully random enough to avoid problems."

1 0

[Cl-darcs-cvs] r46 - cl-darcs/trunk
by mhenoch＠common-lisp.net 06 Oct '06

06 Oct '06

Author: mhenoch Date: Fri Oct 6 15:20:19 2006 New Revision: 46 Modified: cl-darcs/trunk/write-patch.lisp Log: Use pathname-to-string in write-patch Modified: cl-darcs/trunk/write-patch.lisp ============================================================================== --- cl-darcs/trunk/write-patch.lisp (original) +++ cl-darcs/trunk/write-patch.lisp Fri Oct 6 15:20:19 2006 @@ -50,7 +50,7 @@ (write-as-bytes (concatenate 'string "hunk " - (patch-filename patch) + (pathname-to-string (patch-filename patch)) (format nil " ~A" (hunk-line-number patch))) stream) (write-byte 10 stream) @@ -66,7 +66,7 @@ (defun write-token-and-filename (token filename stream) (write-as-bytes token stream) (write-byte 32 stream) - (write-as-bytes filename stream) + (write-as-bytes (pathname-to-string filename) stream) (write-byte 10 stream)) (defmethod write-patch ((patch add-file-patch) stream) @@ -102,7 +102,7 @@ (defmethod write-patch ((patch token-replace-patch) stream) (write-as-bytes (format nil "replace ~A [~A] ~A ~A" - (patch-filename patch) + (pathname-to-string (patch-filename patch)) (token-regexp patch) (old-token patch) (new-token patch)) @@ -138,8 +138,12 @@ (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-sequence (string-to-bytes + (pathname-to-string (patch-move-from patch))) + stream) (write-byte 32 stream) - (write-sequence (string-to-bytes (patch-move-to patch)) stream) + (write-sequence (string-to-bytes + (pathname-to-string + (patch-move-to patch))) stream) (write-byte 10 stream))

1 0

[Cl-darcs-cvs] r45 - cl-darcs/trunk
by mhenoch＠common-lisp.net 06 Oct '06

06 Oct '06

Author: mhenoch Date: Fri Oct 6 15:18:24 2006 New Revision: 45 Modified: cl-darcs/trunk/util.lisp Log: Add function pathname-to-string Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Fri Oct 6 15:18:24 2006 @@ -201,6 +201,21 @@ (make-pathname :directory (cons :relative directory) :name filename-without-dot :type type)))))) +(defun pathname-to-string (pathname) + "Convert PATHNAME to a string usable in darcs patch files. +PATHNAME is assumed to be a relative pathname going strictly down, +as returned by SANITIZE-FILENAME." + (apply #'concatenate 'string + "./" + (append + (mapcan (lambda (d) + (list d "/")) + (cdr (pathname-directory pathname))) + (when (pathname-name pathname) + (cons (pathname-name pathname) + (when (pathname-type pathname) + (list "." (pathname-type pathname)))))))) + (defun make-dir (pathname) "Create directory PATHNAME." (with-simple-restart (ignore-error "Ignore ~A directory creation error." pathname)

1 0

[Cl-darcs-cvs] r44 - cl-darcs/trunk
by mhenoch＠common-lisp.net 06 Oct '06

06 Oct '06

Author: mhenoch Date: Fri Oct 6 14:51:38 2006 New Revision: 44 Modified: cl-darcs/trunk/util.lisp Log: Fix the exclusion feature of copy-directory. Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Fri Oct 6 14:51:38 2006 @@ -223,23 +223,25 @@ to exclude. Symlinks will confuse the function." - (setq excluding (mapcar #'truename excluding)) (let* ((wild (make-pathname :directory '(:relative :wild-inferiors) :name :wild :type :wild :version :wild)) (source-wild (merge-pathnames wild source)) (target-wild (merge-pathnames wild target)) + (excluding-wild (mapcar + (lambda (excluded) (merge-pathnames wild excluded)) + excluding)) (files (fad:list-directory (truename source)))) (dolist (source-file files) (let ((target-file (translate-pathname source-file source-wild target-wild))) (cond - ((member source-file excluding :test #'equal) + ((some (lambda (excluded) (pathname-match-p source-file excluded)) excluding-wild) ;; File excluded - do nothing. ) ((fad:directory-pathname-p source-file) (make-dir target-file) - (copy-directory source-file target-file)) + (copy-directory source-file target-file :excluding excluding)) (t (fad:copy-file source-file target-file)))))))

1 0

[Cl-darcs-cvs] r43 - cl-darcs/trunk
by mhenoch＠common-lisp.net 06 Oct '06

06 Oct '06

Author: mhenoch Date: Fri Oct 6 13:07:36 2006 New Revision: 43 Modified: cl-darcs/trunk/util.lisp Log: Add copy-directory. Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Fri Oct 6 13:07:36 2006 @@ -215,3 +215,31 @@ #+sbcl (sb-posix:rmdir pathname) #-(or clisp sbcl) (error "DELETE-DIR not implemented for ~A." (lisp-implementation-type))) + +(defun copy-directory (source target &key excluding) + "Copy all files and directories in SOURCE to TARGET. +SOURCE and TARGET are pathnames designating directories, both of +which must exist. EXCLUDING is a list of files and directories +to exclude. + +Symlinks will confuse the function." + (setq excluding (mapcar #'truename excluding)) + (let* ((wild (make-pathname :directory '(:relative :wild-inferiors) + :name :wild + :type :wild + :version :wild)) + (source-wild (merge-pathnames wild source)) + (target-wild (merge-pathnames wild target)) + + (files (fad:list-directory (truename source)))) + (dolist (source-file files) + (let ((target-file (translate-pathname source-file source-wild target-wild))) + (cond + ((member source-file excluding :test #'equal) + ;; File excluded - do nothing. + ) + ((fad:directory-pathname-p source-file) + (make-dir target-file) + (copy-directory source-file target-file)) + (t + (fad:copy-file source-file target-file)))))))

1 0