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

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

16 Feb '07

Author: mhenoch Date: Thu Feb 15 20:22:57 2007 New Revision: 91 Modified: cl-darcs/trunk/diff.lisp Log: Use enough-namestring instead of translate-pathname (fixes diff on SBCL) Modified: cl-darcs/trunk/diff.lisp ============================================================================== --- cl-darcs/trunk/diff.lisp (original) +++ cl-darcs/trunk/diff.lisp Thu Feb 15 20:22:57 2007 @@ -138,9 +138,9 @@ ;; With fad:list-directory, we get absolute pathnames. We make ;; them relative to the "root", so they can be compared. (flet ((original-to-repo-relative (p) - (translate-pathname p pristine-wild wild)) + (pathname (enough-namestring p pristine))) (modified-to-repo-relative (p) - (translate-pathname p repo-wild wild))) + (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. (let* ((files-in-original

1 0

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

16 Feb '07

Author: mhenoch Date: Thu Feb 15 20:04:53 2007 New Revision: 90 Modified: cl-darcs/trunk/diff.lisp cl-darcs/trunk/util.lisp Log: Ignore boring files when diffing. Enable debug output from diff. Add diff-repo-display. Modified: cl-darcs/trunk/diff.lisp ============================================================================== --- cl-darcs/trunk/diff.lisp (original) +++ cl-darcs/trunk/diff.lisp Thu Feb 15 20:04:53 2007 @@ -159,23 +159,28 @@ (merge-pathnames file repo)) (pathname-string (pathname-to-string file))) - (cond - ((fad:directory-pathname-p file) - (unless (file-boring-p repo pathname-string) - ;; We have a non-boring subdirectory. + (unless (file-boring-p repo pathname-string) + (cond + ((fad:directory-pathname-p file) (setf patches (nconc patches - (diff-repo repo original-pathname modified-pathname))))) + (diff-repo repo original-pathname modified-pathname)))) - ((file-binary-p repo pathname-string) - (setf patches (nconc patches - (diff-binary-file original-pathname - modified-pathname - :filename pathname-string)))) + ((file-binary-p repo pathname-string) + (setf patches (nconc patches + (diff-binary-file original-pathname + modified-pathname + :filename pathname-string)))) - (t - (setf patches (nconc patches - (diff-file original-pathname - modified-pathname - :filename pathname-string))))))) + (t + (setf patches (nconc patches + (diff-file original-pathname + modified-pathname + :filename pathname-string)))))))) patches)))) + +(defun diff-repo-display (repo) + "Find changes in REPO and print them to *STANDARD-OUTPUT*." + (dolist (patch (diff-repo repo)) + (display-patch patch *standard-output*))) + Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Thu Feb 15 20:04:53 2007 @@ -17,7 +17,7 @@ (in-package :darcs) (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter +debugged-modules+ '(get #|read-patch patchinfo|# apply-patch #|init upath|# util) + (defparameter +debugged-modules+ '(get #|read-patch patchinfo|# apply-patch #|init upath|# util diff) "Modules emitting debug output.")) (defvar *http-proxy* nil

1 0

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

15 Feb '07

Author: mhenoch Date: Wed Feb 14 23:00:51 2007 New Revision: 89 Modified: cl-darcs/trunk/commute.lisp Log: More commute methods Modified: cl-darcs/trunk/commute.lisp ============================================================================== --- cl-darcs/trunk/commute.lisp (original) +++ cl-darcs/trunk/commute.lisp Wed Feb 14 23:00:51 2007 @@ -27,6 +27,68 @@ (warn "No method defined for commuting ~A and ~A." p2 p1) nil) +(defmethod commute ((p2 named-patch) (p1 patch)) + "Commute a named patch and another patch." + (destructuring-bind (&optional p1-new p2-new) + (commute (named-patch-patch p2) p1) + (if p1-new + (list p1-new + (make-instance 'named-patch + :patchinfo (named-patch-patchinfo p2) + :dependencies (named-patch-dependencies p2) + :patch p2-new)) + (call-next-method)))) + +(defmethod commute ((p2 patch) (p1 named-patch)) + "Commute a patch with a named patch." + (destructuring-bind (&optional p1-new p2-new) + (commute p2 (named-patch-patch p1)) + (if p1-new + (list (make-instance 'named-patch + :patchinfo (named-patch-patchinfo p1) + :dependencies (named-patch-dependencies p1) + :patch p1-new) + p2-new) + (call-next-method)))) + +(defmethod commute ((p2 move-patch) (p1 file-patch)) + "Commute a move patch with a file patch." + (let ((patched-file (patch-filename p1)) + (moved-from (patch-move-from p2)) + (moved-to (patch-move-to p2))) + (cond + ;; File was patched and then moved + ((equal patched-file moved-from) + (let ((p1-new (copy-patch p1))) + (setf (patch-filename p1-new) moved-to) + (list p1-new p2))) + ;; Another file moved on top of original file + ((equal patched-file moved-to) + (warn "Collision when commuting ~A and ~A." p2 p1) + nil) + ;; Patches touch different files + (t + (list p1 p2))))) + +(defmethod commute ((p2 file-patch) (p1 move-patch)) + "Commute a file patch with a move patch." + (let ((moved-from (patch-move-from p1)) + (moved-to (patch-move-to p1)) + (patched-file (patch-filename p2))) + (cond + ;; File was moved and then patched + ((equal moved-to patched-file) + (let ((p2-new (copy-patch p2))) + (setf (patch-filename p2-new) moved-from) + (list p1 p2-new))) + ;; File was moved before being patched + ((equal moved-from patched-file) + (warn "Collision when commuting ~A and ~A." p2 p1) + nil) + ;; Patches touch different files + (t + (list p1 p2))))) + (defmethod commute :around ((p2 file-patch) (p1 file-patch)) "If P1 and P2 change different files, commutation is trivial." (let ((p1-file (patch-filename p1))

1 0

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

15 Feb '07

Author: mhenoch Date: Wed Feb 14 23:00:30 2007 New Revision: 88 Modified: cl-darcs/trunk/util.lisp Log: Combine regexps into one to reduce memory use. Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Wed Feb 14 23:00:30 2007 @@ -287,13 +287,23 @@ (defun matches-one-of (regexps string) "Return true if some of REGEXPS match STRING. Cache scanners for faster execution beyond first time." - (dolist (regexp regexps) - (let ((scanner (or - (gethash regexp *scanner-cache*) - (setf (gethash regexp *scanner-cache*) - (cl-ppcre:create-scanner regexp))))) - (when (cl-ppcre:scan scanner string) - (return t))))) + ;; These scanners use _a lot_ of memory, so we build just one, and + ;; hope that the exact combination of regexps will be used often + ;; enough. + (setq regexps (sort (copy-seq regexps) #'string>)) + (let* ((combined-regexp + (apply + #'concatenate 'string + (loop for regexp in regexps + for n upfrom 0 + unless (zerop n) collect "|" + collect regexp))) + (scanner (or + (gethash combined-regexp *scanner-cache*) + (setf (gethash combined-regexp *scanner-cache*) + (cl-ppcre:create-scanner combined-regexp))))) + (when (cl-ppcre:scan scanner string) + t))) (defun file-binary-p (repo filename) "Return true if FILENAME names a binary file.

1 0

[Cl-darcs-cvs] r87 - cl-darcs/trunk
by mhenoch＠common-lisp.net 09 Feb '07

09 Feb '07

Author: mhenoch Date: Fri Feb 9 13:30:27 2007 New Revision: 87 Modified: cl-darcs/trunk/util.lisp Log: Implement compress-file for SBCL Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Fri Feb 9 13:30:27 2007 @@ -150,6 +150,11 @@ (ext:run-program "gzip" :input (namestring infile) :output (namestring outfile) :if-output-exists :error) (dformat "done")) + #+sbcl + ((pathnamep infile) + (dformat "~&Compressing ~A through external program..." outfile) + (sb-ext:run-program "/usr/bin/gzip" nil :input infile :output outfile + :if-output-exists :error)) (t (cerror "Assume compression performed." "Don't know how to gzip ~A to ~A." infile outfile))))

1 0

[Cl-darcs-cvs] r86 - cl-darcs/trunk
by mhenoch＠common-lisp.net 08 Feb '07

08 Feb '07

Author: mhenoch Date: Wed Feb 7 21:34:16 2007 New Revision: 86 Modified: cl-darcs/trunk/patch-core.lisp Log: Unquote type declarations. Modified: cl-darcs/trunk/patch-core.lisp ============================================================================== --- cl-darcs/trunk/patch-core.lisp (original) +++ cl-darcs/trunk/patch-core.lisp Wed Feb 7 21:34:16 2007 @@ -65,17 +65,17 @@ (defclass binary-patch (file-patch) ((oldhex :accessor binary-oldhex :initarg :oldhex - :type '(vector (unsigned-byte 8)) + :type (vector (unsigned-byte 8)) :documentation "The old contents of the file.") (newhex :accessor binary-newhex :initarg :newhex - :type '(vector (unsigned-byte 8)) + :type (vector (unsigned-byte 8)) :documentation "The new contents of the file.")) (:documentation "A patch that changes a binary file.")) (defclass token-replace-patch (file-patch) - ((regexp :accessor token-regexp :initarg :regexp :type 'string) - (old-token :accessor old-token :initarg :old-token :type 'string) - (new-token :accessor new-token :initarg :new-token :type 'string)) + ((regexp :accessor token-regexp :initarg :regexp :type string) + (old-token :accessor old-token :initarg :old-token :type string) + (new-token :accessor new-token :initarg :new-token :type string)) (:documentation "A patch that replaces one token with another.")) (defmethod print-object ((patch token-replace-patch) stream)

1 0

[Cl-darcs-cvs] r85 - cl-darcs/trunk
by mhenoch＠common-lisp.net 08 Feb '07

08 Feb '07

Author: mhenoch Date: Wed Feb 7 21:31:49 2007 New Revision: 85 Modified: cl-darcs/trunk/pull.lisp Log: Add missing format argument. Modified: cl-darcs/trunk/pull.lisp ============================================================================== --- cl-darcs/trunk/pull.lisp (original) +++ cl-darcs/trunk/pull.lisp Wed Feb 7 21:31:49 2007 @@ -75,6 +75,6 @@ (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 "~&~<Some patches could not be applied to the source tree. ~ +You should manually merge changes from the pristine tree in _darcs/pristine/.~>" nil))))) (format t "~&All done")))

1 0