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

[Cl-darcs-cvs] r137 - cl-darcs/trunk
by mhenoch＠common-lisp.net 05 Sep '07

05 Sep '07

Author: mhenoch Date: Wed Sep 5 17:55:23 2007 New Revision: 137 Modified: cl-darcs/trunk/util.lisp Log: PATHNAME-SANE-P: pathnames without directory components are sane Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Wed Sep 5 17:55:23 2007 @@ -228,9 +228,10 @@ (defun pathname-sane-p (pathname) "Return true if PATHNAME is a relative path going strictly down." (let ((directory (pathname-directory pathname))) - (and (listp directory) - (eql (car directory) :relative) - (every #'stringp (cdr directory))))) + (or (null directory) + (and (listp directory) + (eql (car directory) :relative) + (every #'stringp (cdr directory)))))) (defun pathname-to-string (pathname) "Convert PATHNAME to a string usable in darcs patch files.

1 0

[Cl-darcs-cvs] r136 - cl-darcs/trunk
by mhenoch＠common-lisp.net 05 Sep '07

05 Sep '07

Author: mhenoch Date: Wed Sep 5 17:50:48 2007 New Revision: 136 Modified: cl-darcs/trunk/diff.lisp Log: s/:forward/:forwards/ Modified: cl-darcs/trunk/diff.lisp ============================================================================== --- cl-darcs/trunk/diff.lisp (original) +++ cl-darcs/trunk/diff.lisp Wed Sep 5 17:50:48 2007 @@ -174,7 +174,7 @@ (dolist (file files-in-original) ;; Was it touched by some "pending" patch? (multiple-value-bind (touching new-name) - (find-touching pending file :forward) + (find-touching pending file :forwards) (if touching ;; If yes, we want to record those patches, and remember the new name. (setf patches (nconc patches (patches touching)))

1 0

[Cl-darcs-cvs] r135 - cl-darcs/trunk
by mhenoch＠common-lisp.net 05 Sep '07

05 Sep '07

Author: mhenoch Date: Wed Sep 5 17:50:01 2007 New Revision: 135 Modified: cl-darcs/trunk/diff.lisp Log: Fix DIFF-REPO when there is no pending patch Modified: cl-darcs/trunk/diff.lisp ============================================================================== --- cl-darcs/trunk/diff.lisp (original) +++ cl-darcs/trunk/diff.lisp Wed Sep 5 17:50:01 2007 @@ -133,7 +133,9 @@ (pristine-wild (merge-pathnames wild pristine)) (original-wild (merge-pathnames wild original)) (modified-wild (merge-pathnames wild modified)) - (pending (read-pending repo)) + (pending (or + (read-pending repo) + (make-instance 'composite-patch :patches ()))) patches) ;; XXX: check if both directories exist

1 0

[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