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

[Cl-darcs-cvs] r134 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Aug '07

24 Aug '07

Author: mhenoch Date: Fri Aug 24 13:33:10 2007 New Revision: 134 Modified: cl-darcs/trunk/diff.lisp Log: Use the "pending" patch to keep track of new files and directories when diffing. Modified: cl-darcs/trunk/diff.lisp ============================================================================== --- cl-darcs/trunk/diff.lisp (original) +++ cl-darcs/trunk/diff.lisp Fri Aug 24 13:33:10 2007 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2006 Magnus Henoch +;;; Copyright (C) 2006, 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 @@ -19,16 +19,16 @@ (defun diff-file (original modified &key filename) "Find changes between ORIGINAL and MODIFIED. Return a list of HUNK-PATCHes. Use FILENAME as their filename." - (setf original (make-upath original)) - (setf modified (make-upath modified)) + (when original (setf original (make-upath original))) + (when modified (setf modified (make-upath modified))) (let* ((original-lines - (if (fad:file-exists-p original) + (if original (with-open-stream (in (open-upath original :binary t)) (loop for line = (read-binary-line in nil) while line collect line)) :nonexistent)) (modified-lines - (if (fad:file-exists-p modified) + (if modified (with-open-stream (in (open-upath modified :binary t)) (loop for line = (read-binary-line in nil) while line collect line)) @@ -51,10 +51,7 @@ (error "Neither ~A nor ~A exist." original modified)) ((eql original-lines :nonexistent) ;; Newly created file - ;; XXX: should we automatically add such files? (list - (make-instance 'add-file-patch - :filename filename) (make-instance 'hunk-patch :filename filename :line-number 1 @@ -67,9 +64,7 @@ :filename filename :line-number 1 :old original-lines - :new ()) - (make-instance 'rm-file-patch - :filename filename))) + :new ()))) (t ;; Possibly changed file (dolist (opcode opcodes) @@ -90,29 +85,35 @@ (defun diff-binary-file (original modified &key filename) "Find changes between binary files ORIGINAL and MODIFIED. +ORIGINAL and MODIFIED can be NIL, meaning an empty file. Use FILENAME as their filename. Return a list of one BINARY-PATCH, or an empty list if the files are equal." - (with-open-file (o original - :direction :input :if-does-not-exist :error - :element-type '(unsigned-byte 8)) - (with-open-file (m modified - :direction :input :if-does-not-exist :error - :element-type '(unsigned-byte 8)) - (let ((o-contents - (make-array (file-length o) - :element-type '(unsigned-byte 8))) - (m-contents - (make-array (file-length m) - :element-type '(unsigned-byte 8)))) - (read-sequence o-contents o) - (read-sequence m-contents m) - (unless (equalp o-contents m-contents) - (list - (make-instance 'binary-patch - :filename filename - :oldhex o-contents - :newhex m-contents))))))) + (let ((o-contents + (when original + (with-open-file (o original + :direction :input :if-does-not-exist :error + :element-type '(unsigned-byte 8)) + (let ((data + (make-array (file-length o) + :element-type '(unsigned-byte 8)))) + (read-sequence data o))))) + (m-contents + (when modified + (with-open-file (m modified + :direction :input :if-does-not-exist :error + :element-type '(unsigned-byte 8)) + (let ((data + (make-array (file-length m) + :element-type '(unsigned-byte 8)))) + (read-sequence data m))))) + (empty (make-array 0 :element-type '(unsigned-byte 8)))) + (unless (equalp o-contents m-contents) + (list + (make-instance 'binary-patch + :filename filename + :oldhex (or o-contents empty) + :newhex (or m-contents empty)))))) (defun diff-repo (repo &optional original modified) "Find changes in REPO from pristine tree. @@ -132,6 +133,7 @@ (pristine-wild (merge-pathnames wild pristine)) (original-wild (merge-pathnames wild original)) (modified-wild (merge-pathnames wild modified)) + (pending (read-pending repo)) patches) ;; XXX: check if both directories exist @@ -141,25 +143,48 @@ (pathname (enough-namestring p pristine))) (modified-to-repo-relative (p) (pathname (enough-namestring p repo)))) - ;; We list the files in the current directory, both in the - ;; original and the modified tree, and get the union. + ;; We list the files in the original tree. (let* ((files-in-original (mapcar #'original-to-repo-relative (fad:list-directory original))) - (files-in-modified - (mapcar #'modified-to-repo-relative - (fad:list-directory modified))) - (files (nunion files-in-original files-in-modified - :test #'equal))) - ;; Then we iterate through the union. - (dolist (file files) - (let ((original-pathname - (merge-pathnames file pristine)) - (modified-pathname - (merge-pathnames file repo)) - (pathname-string - (pathname-to-string file))) - (unless (file-boring-p repo pathname-string) + pruned-pending) + ;; Create patch objects for newly added files and directories, + ;; and remember pending patches not creating new files or + ;; directories. + (dolist (p (patches pending)) + (typecase p + (add-file-patch + (let ((pathname-string (pathname-to-string (patch-filename p))) + (new-file (merge-pathnames (patch-filename p) repo))) + (setf patches + (nconc patches + (list* p + (if (file-binary-p repo pathname-string) + (diff-binary-file nil new-file :filename pathname-string) + (diff-file nil new-file :filename pathname-string))))))) + (add-dir-patch + (setf patches (nconc patches (list p)))) + (t + (push p pruned-pending)))) + (setf (patches pending) (nreverse pruned-pending)) + + ;; Then for each original file, find out its fate. + (dolist (file files-in-original) + ;; Was it touched by some "pending" patch? + (multiple-value-bind (touching new-name) + (find-touching pending file :forward) + (if touching + ;; If yes, we want to record those patches, and remember the new name. + (setf patches (nconc patches (patches touching))) + ;; If not, it has the same name as before. + (setf new-name file)) + + (let ((original-pathname + (merge-pathnames file pristine)) + (modified-pathname + (merge-pathnames new-name repo)) + (pathname-string + (pathname-to-string new-name))) (cond ((fad:directory-pathname-p file) (setf patches (nconc patches

1 0

[Cl-darcs-cvs] r133 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Aug '07

24 Aug '07

Author: mhenoch Date: Fri Aug 24 13:31:19 2007 New Revision: 133 Modified: cl-darcs/trunk/README Log: Update dependcy information in README Modified: cl-darcs/trunk/README ============================================================================== --- cl-darcs/trunk/README (original) +++ cl-darcs/trunk/README Fri Aug 24 13:31:19 2007 @@ -40,12 +40,13 @@ * Dependencies - split-sequence: http://www.cl-user.net/asp/libs/split-sequence - - Portable AllegroServe: http://portableaserve.sourceforge.net/ - - trivial-gray-streams: - http://www.cl-user.net/asp/libs/trivial-gray-streams + - Drakma: http://weitz.de/drakma/ + - PURI: http://puri.b9.com/ + - trivial-gray-streams: http://www.cl-user.net/asp/libs/trivial-gray-streams - Ironclad: http://www.cl-user.net/asp/libs/ironclad + - FLEXI-STREAMS: http://weitz.de/flexi-streams/ - CL-FAD: http://weitz.de/cl-fad/ - - For CLISP, you need SB-SHA1: http://www.cliki.net/sb-sha1 + - CL-PPCRE: http://weitz.de/cl-ppcre/ All of these are ASDF-INSTALLable.

1 0

[Cl-darcs-cvs] r132 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Aug '07

24 Aug '07

Author: mhenoch Date: Fri Aug 24 13:26:49 2007 New Revision: 132 Modified: cl-darcs/trunk/packages.lisp Log: Export ADD-FILE from package Modified: cl-darcs/trunk/packages.lisp ============================================================================== --- cl-darcs/trunk/packages.lisp (original) +++ cl-darcs/trunk/packages.lisp Fri Aug 24 13:26:49 2007 @@ -7,4 +7,5 @@ #:*http-proxy* #:get-repo #:pull #:diff-repo #:diff-repo-display #:record-changes #:create-repo - #:revert-changes #:send-to-file)) + #:revert-changes #:send-to-file + #:add-file))

1 0

[Cl-darcs-cvs] r131 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Aug '07

24 Aug '07

Author: mhenoch Date: Fri Aug 24 13:25:20 2007 New Revision: 131 Modified: cl-darcs/trunk/pending.lisp Log: Use ENOUGH-NAMESTRING to permit more user convenience in ADD-FILE Modified: cl-darcs/trunk/pending.lisp ============================================================================== --- cl-darcs/trunk/pending.lisp (original) +++ cl-darcs/trunk/pending.lisp Fri Aug 24 13:25:20 2007 @@ -42,18 +42,13 @@ FILE can be a string or a pathname denoting a relative path. FILE can be either a file or a directory." (setf repo (fad:pathname-as-directory repo)) - (let (type) - (if (pathnamep file) - (progn - (unless (pathname-sane-p file) - (error "~A is not a relative pathname going strictly down." file)) - (setf type (if (fad:directory-pathname-p file) :directory :file))) - (progn - (setf type (if (fad:directory-exists-p - (fad:pathname-as-directory (merge-pathnames file repo))) - :directory - :file)) - (setf file (sanitize-filename file :type type)))) + (setf file (enough-namestring file repo)) + (let ((type + (if (fad:directory-exists-p + (fad:pathname-as-directory (merge-pathnames file repo))) + :directory + :file))) + (setf file (sanitize-filename file :type type)) (let ((pristine-file (merge-pathnames file (upath-subdir repo '("_darcs" "pristine")))) (working-file (merge-pathnames file repo))) @@ -71,4 +66,4 @@ repo (if (eql type :file) (make-instance 'add-file-patch :filename file) - (make-instance 'add-dir-patch :directory file))))) + (make-instance 'add-dir-patch :directory file))))) \ No newline at end of file

1 0

[Cl-darcs-cvs] r130 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Aug '07

24 Aug '07

Author: mhenoch Date: Fri Aug 24 13:20:35 2007 New Revision: 130 Modified: cl-darcs/trunk/pending.lisp Log: Fix ADD-FILE existing file test Modified: cl-darcs/trunk/pending.lisp ============================================================================== --- cl-darcs/trunk/pending.lisp (original) +++ cl-darcs/trunk/pending.lisp Fri Aug 24 13:20:35 2007 @@ -49,7 +49,8 @@ (error "~A is not a relative pathname going strictly down." file)) (setf type (if (fad:directory-pathname-p file) :directory :file))) (progn - (setf type (if (fad:directory-exists-p (fad:pathname-as-directory file)) + (setf type (if (fad:directory-exists-p + (fad:pathname-as-directory (merge-pathnames file repo))) :directory :file)) (setf file (sanitize-filename file :type type)))) @@ -64,6 +65,7 @@ (fad:file-exists-p working-file) (fad:directory-exists-p working-file))) (error "~A does not exist in the working directory." (pathname-to-string file)))) + ;; XXX: check that all parent directories exist, either in pristine or in pending (add-to-pending repo

1 0

[Cl-darcs-cvs] r129 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Aug '07

24 Aug '07

Author: mhenoch Date: Fri Aug 24 13:01:39 2007 New Revision: 129 Modified: cl-darcs/trunk/touching.lisp Log: Make FIND-TOUCHING for COMPOSITE-PATCH return two values. Modified: cl-darcs/trunk/touching.lisp ============================================================================== --- cl-darcs/trunk/touching.lisp (original) +++ cl-darcs/trunk/touching.lisp Fri Aug 24 13:01:39 2007 @@ -54,7 +54,7 @@ (when (null filename) (return))))) (when touching-patches - (make-instance 'composite-patch :patches (nreverse touching-patches))))) + (values (make-instance 'composite-patch :patches (nreverse touching-patches)) filename)))) (defmethod find-touching :around ((patch file-patch) filename direction) ;; File patches touch a single file, so we can ignore them if they

1 0

[Cl-darcs-cvs] r128 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Aug '07

24 Aug '07

Author: mhenoch Date: Fri Aug 24 08:30:54 2007 New Revision: 128 Modified: cl-darcs/trunk/touching.lisp Log: Add FIND-TOUCHING methods for DIRECTORY-PATCH and subclasses. Add warnings for bizarre situations. Modified: cl-darcs/trunk/touching.lisp ============================================================================== --- cl-darcs/trunk/touching.lisp (original) +++ cl-darcs/trunk/touching.lisp Fri Aug 24 08:30:54 2007 @@ -75,6 +75,7 @@ ;; Should this happen in normal circumstances? If the file was ;; created by this patch, noone would know about its existence ;; before. + (warn "FIND-TOUCHING: File ~A is being added, but it already exists." filename) (values patch filename)) (:backwards ;; Before this patch, the file didn't exist. @@ -88,12 +89,32 @@ (values patch nil)) (:backwards ;; Should this happen? + (warn "FIND-TOUCHING: File ~A was removed, but it still exists." filename) (values patch filename)))) -(defmethod find-touching ((patch directory-patch) filename direction) +(defmethod find-touching :around ((patch directory-patch) filename direction) (declare (ignore direction)) (when (equal filename (patch-directory patch)) - (values patch filename))) + (call-next-method))) + +(defmethod find-touching ((patch add-dir-patch) filename direction) + (ecase direction + (:forwards + ;; Should this happen? + (warn "FIND-TOUCHING: Directory ~A is being added, but it already exists." filename) + (values patch filename)) + (:backwards + ;; Before this patch, the directory didn't exist. + (values patch nil)))) + +(defmethod find-touching ((patch rm-dir-patch) filename direction) + (ecase direction + (:forwards + ;; After this patch, the directory doesn't exist. + (values patch nil)) + (:backwards + (warn "FIND-TOUCHING: Directory ~A was removed, but it still exists." filename) + (values patch filename)))) (defmethod find-touching ((patch named-patch) filename direction) (multiple-value-bind (touching-patch new-name)

1 0

[Cl-darcs-cvs] r127 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Aug '07

24 Aug '07

Author: mhenoch Date: Fri Aug 24 08:25:38 2007 New Revision: 127 Modified: cl-darcs/trunk/touching.lisp Log: Add FIND-TOUCHING methods for FILE-PATCH, ADD-FILE-PATCH and RM-FILE-PATCH. Modified: cl-darcs/trunk/touching.lisp ============================================================================== --- cl-darcs/trunk/touching.lisp (original) +++ cl-darcs/trunk/touching.lisp Fri Aug 24 08:25:38 2007 @@ -56,10 +56,39 @@ (when touching-patches (make-instance 'composite-patch :patches (nreverse touching-patches))))) -(defmethod find-touching ((patch file-patch) filename direction) +(defmethod find-touching :around ((patch file-patch) filename direction) + ;; File patches touch a single file, so we can ignore them if they + ;; don't touch the file we're interested in. (declare (ignore direction)) (when (equal filename (patch-filename patch)) - (values patch filename))) + (call-next-method))) + +(defmethod find-touching ((patch file-patch) filename direction) + ;; By default, assume that file patches modify an existing file. + (declare (ignore direction)) + (values patch filename)) + +(defmethod find-touching ((patch add-file-patch) filename direction) + ;; Adding a file is different, though. + (ecase direction + (:forwards + ;; Should this happen in normal circumstances? If the file was + ;; created by this patch, noone would know about its existence + ;; before. + (values patch filename)) + (:backwards + ;; Before this patch, the file didn't exist. + (values patch nil)))) + +(defmethod find-touching ((patch rm-file-patch) filename direction) + ;; As is removing a file. + (ecase direction + (:forwards + ;; After this patch, the file doesn't exist. + (values patch nil)) + (:backwards + ;; Should this happen? + (values patch filename)))) (defmethod find-touching ((patch directory-patch) filename direction) (declare (ignore direction))

1 0

[Cl-darcs-cvs] r126 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Aug '07

24 Aug '07

Author: mhenoch Date: Fri Aug 24 08:15:10 2007 New Revision: 126 Modified: cl-darcs/trunk/touching.lisp Log: Make FIND-TOUCHING direction-aware Modified: cl-darcs/trunk/touching.lisp ============================================================================== --- cl-darcs/trunk/touching.lisp (original) +++ cl-darcs/trunk/touching.lisp Fri Aug 24 08:15:10 2007 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2006 Magnus Henoch +;;; Copyright (C) 2006, 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 @@ -16,41 +16,74 @@ (in-package :cl-darcs) -(defgeneric find-touching (patch filename) +(defgeneric find-touching (patch filename direction) (:documentation "Find and return the subset of PATCH that touches FILENAME. -Return NIL if PATCH doesn't touch FILENAME at all.")) -(defmethod find-touching :around (patch (filename string)) - (find-touching patch (sanitize-filename filename))) +DIRECTION is either :FORWARDS or :BACKWARDS. If it is :FORWARDS, +FILENAME is the name of the file before this patch; if :BACKWARDS, +after. + +Two values are returned, the subset patch, and the new name of the +file. The subset patch is NIL if PATCH doesn't touch FILENAME at all. +The name is the same as the old one, if the patch didn't +change the file's name. The name is NIL if the file doesn't exist +before/after the patch, or if the patch doesn't touch the file.")) -(defmethod find-touching ((patch patch) filename) +(defmethod find-touching :around (patch (filename string) direction) + (find-touching patch (sanitize-filename filename) direction)) + +(defmethod find-touching ((patch patch) filename direction) "This least specific method returns NIL." - (declare (ignore filename)) + (declare (ignore filename direction)) nil) -(defmethod find-touching ((patch composite-patch) filename) +(defmethod find-touching ((patch composite-patch) filename direction) "Return a new composite patch containing those patches that touch FILENAME. Return nil if no patches do." - (let ((touching-patches - (loop for p in (patches patch) - when (find-touching p filename) - collect it))) + (let ((patches (ecase direction + (:forwards (patches patch)) + (:backwards (reverse (patches patch))))) + touching-patches) + (dolist (p patches) + (multiple-value-bind + (subset-patch new-name) + (find-touching p filename direction) + (when subset-patch + (push subset-patch touching-patches) + (setf filename new-name) + (when (null filename) + (return))))) (when touching-patches - (make-instance 'composite-patch :patches touching-patches)))) + (make-instance 'composite-patch :patches (nreverse touching-patches))))) -(defmethod find-touching ((patch file-patch) filename) +(defmethod find-touching ((patch file-patch) filename direction) + (declare (ignore direction)) (when (equal filename (patch-filename patch)) - patch)) + (values patch filename))) -(defmethod find-touching ((patch directory-patch) filename) +(defmethod find-touching ((patch directory-patch) filename direction) + (declare (ignore direction)) (when (equal filename (patch-directory patch)) - patch)) + (values patch filename))) -(defmethod find-touching ((patch named-patch) filename) - (let ((touching-patch (find-touching (named-patch-patch patch) filename))) +(defmethod find-touching ((patch named-patch) filename direction) + (multiple-value-bind (touching-patch new-name) + (find-touching (named-patch-patch patch) filename direction) (when touching-patch - (make-instance 'named-patch - :patchinfo (named-patch-patchinfo patch) - :dependencies (named-patch-dependencies patch) - :patch touching-patch)))) - + (values + (make-instance 'named-patch + :patchinfo (named-patch-patchinfo patch) + :dependencies (named-patch-dependencies patch) + :patch touching-patch) + new-name)))) + +(defmethod find-touching ((patch move-patch) filename direction) + (let ((from (patch-move-from patch)) + (to (patch-move-to patch))) + (ecase direction + (:forwards + (when (equal filename from) + (values patch to))) + (:backwards + (when (equal filename to) + (values patch from))))))

1 0

[Cl-darcs-cvs] r125 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Aug '07

24 Aug '07

Author: mhenoch Date: Fri Aug 24 08:11:44 2007 New Revision: 125 Modified: cl-darcs/trunk/pending.lisp Log: Don't convert pathname to string when creating patch objects Modified: cl-darcs/trunk/pending.lisp ============================================================================== --- cl-darcs/trunk/pending.lisp (original) +++ cl-darcs/trunk/pending.lisp Fri Aug 24 08:11:44 2007 @@ -68,5 +68,5 @@ (add-to-pending repo (if (eql type :file) - (make-instance 'add-file-patch :filename (pathname-to-string file)) - (make-instance 'add-dir-patch :directory (pathname-to-string file)))))) + (make-instance 'add-file-patch :filename file) + (make-instance 'add-dir-patch :directory file)))))

1 0