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

[Cl-darcs-cvs] r74 - cl-darcs/trunk
by mhenoch＠common-lisp.net 27 Nov '06

27 Nov '06

Author: mhenoch Date: Mon Nov 27 16:41:32 2006 New Revision: 74 Modified: cl-darcs/trunk/diff.lisp Log: Handle added and removed files Modified: cl-darcs/trunk/diff.lisp ============================================================================== --- cl-darcs/trunk/diff.lisp (original) +++ cl-darcs/trunk/diff.lisp Mon Nov 27 16:41:32 2006 @@ -22,39 +22,71 @@ (setf original (make-upath original)) (setf modified (make-upath modified)) (let* ((original-lines - (with-open-stream (in (open-upath original :binary t)) - (loop for line = (read-binary-line in nil) - while line collect line))) + (if (fad:file-exists-p 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 - (with-open-stream (in (open-upath modified :binary t)) - (loop for line = (read-binary-line in nil) - while line collect line))) + (if (fad:file-exists-p modified) + (with-open-stream (in (open-upath modified :binary t)) + (loop for line = (read-binary-line in nil) + while line collect line)) + :nonexistent)) ;; using equalp is safe (i.e. non-case-clobbering), as ;; we use bytes instead of characters - (opcodes (difflib:get-opcodes - (make-instance 'difflib:sequence-matcher - :a original-lines - :b modified-lines - :test-function #'equalp))) + (opcodes (when (and (listp original-lines) + (listp modified-lines)) + (difflib:get-opcodes + (make-instance 'difflib:sequence-matcher + :a original-lines + :b modified-lines + :test-function #'equalp)))) patches) + (cond + ((and (eql original-lines :nonexistent) + (eql modified-lines :nonexistent)) + (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 + :old () + :new modified-lines))) + ((eql modified-lines :nonexistent) + ;; Removed file + (list + (make-instance 'hunk-patch + :filename filename + :line-number 1 + :old original-lines + :new ()) + (make-instance 'rm-file-patch + :filename filename))) + (t + ;; Possibly changed file + (dolist (opcode opcodes) + (unless (eql (difflib:opcode-tag opcode) :equal) + (push + (make-instance 'hunk-patch + :filename filename + :line-number (difflib:opcode-j1 opcode) + :old (subseq original-lines + (difflib:opcode-i1 opcode) + (difflib:opcode-i2 opcode)) + :new (subseq modified-lines + (difflib:opcode-j1 opcode) + (difflib:opcode-j2 opcode))) + patches))) - (dolist (opcode opcodes) - (unless (eql (difflib:opcode-tag opcode) :equal) - (push - (make-instance 'hunk-patch - :filename filename - :line-number (difflib:opcode-j1 opcode) - :old (subseq original-lines - (difflib:opcode-i1 opcode) - (difflib:opcode-i2 opcode)) - :new (subseq modified-lines - (difflib:opcode-j1 opcode) - (difflib:opcode-j2 opcode))) - patches))) - - (nreverse patches))) + (nreverse patches))))) (defun diff-binary-file (original modified &key filename) "Find changes between binary files ORIGINAL and MODIFIED. @@ -96,34 +128,54 @@ :type :wild :version :wild)) (repo-wild (merge-pathnames wild repo)) + (pristine (upath-subdir repo '("_darcs" "pristine"))) + (pristine-wild (merge-pathnames wild pristine)) (original-wild (merge-pathnames wild original)) (modified-wild (merge-pathnames wild modified)) patches) - (dolist (original-pathname (fad:list-directory original)) - (let* ((modified-pathname - (translate-pathname original-pathname original-wild modified-wild)) - (pathname-string - (pathname-to-string - (translate-pathname modified-pathname repo-wild wild)))) - (cond - ((fad:directory-pathname-p original-pathname) - (format t "~&Skipping directory ~A for now" modified-pathname) - (let ((last-element (car (last (pathname-directory original-pathname))))) - (unless (file-boring-p repo last-element) - ;; We have a non-boring subdirectory. - (setf patches (nconc patches - (diff-repo repo original-pathname modified-pathname)))))) + ;; XXX: check if both directories exist - ((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))))))) + ;; 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)) + (modified-to-repo-relative (p) + (translate-pathname p repo-wild wild))) + ;; We list the files in the current directory, both in the + ;; original and the modified tree, and get the union. + (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))) + (cond + ((fad:directory-pathname-p file) + (unless (file-boring-p repo pathname-string) + ;; We have a non-boring subdirectory. + (setf patches (nconc patches + (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)))) + + (t + (setf patches (nconc patches + (diff-file original-pathname + modified-pathname + :filename pathname-string))))))) - patches)) + patches))))

1 0

[Cl-darcs-cvs] r73 - cl-darcs/trunk
by mhenoch＠common-lisp.net 22 Nov '06

22 Nov '06

Author: mhenoch Date: Wed Nov 22 16:56:23 2006 New Revision: 73 Modified: cl-darcs/trunk/packages.lisp Log: Export diff-repo Modified: cl-darcs/trunk/packages.lisp ============================================================================== --- cl-darcs/trunk/packages.lisp (original) +++ cl-darcs/trunk/packages.lisp Wed Nov 22 16:56:23 2006 @@ -4,4 +4,4 @@ (:use :cl) (:nicknames :cl-darcs) (:export - #:get-repo #:pull #:*http-proxy*)) + #:get-repo #:pull #:diff-repo #:*http-proxy*))

1 0

[Cl-darcs-cvs] r72 - cl-darcs/trunk
by mhenoch＠common-lisp.net 22 Nov '06

22 Nov '06

Author: mhenoch Date: Wed Nov 22 15:54:41 2006 New Revision: 72 Modified: cl-darcs/trunk/diff.lisp Log: Fix modified-pathname Modified: cl-darcs/trunk/diff.lisp ============================================================================== --- cl-darcs/trunk/diff.lisp (original) +++ cl-darcs/trunk/diff.lisp Wed Nov 22 15:54:41 2006 @@ -100,11 +100,11 @@ (modified-wild (merge-pathnames wild modified)) patches) (dolist (original-pathname (fad:list-directory original)) - (let ((pathname-string - (pathname-to-string - (translate-pathname original-pathname original-wild repo-wild))) - (modified-pathname - (translate-pathname original-pathname original-wild modified-wild))) + (let* ((modified-pathname + (translate-pathname original-pathname original-wild modified-wild)) + (pathname-string + (pathname-to-string + (translate-pathname modified-pathname repo-wild wild)))) (cond ((fad:directory-pathname-p original-pathname) (format t "~&Skipping directory ~A for now" modified-pathname)

1 0

[Cl-darcs-cvs] r71 - cl-darcs/trunk
by mhenoch＠common-lisp.net 22 Nov '06

22 Nov '06

Author: mhenoch Date: Wed Nov 22 15:52:56 2006 New Revision: 71 Modified: cl-darcs/trunk/diff.lisp Log: Diff directories recursively Modified: cl-darcs/trunk/diff.lisp ============================================================================== --- cl-darcs/trunk/diff.lisp (original) +++ cl-darcs/trunk/diff.lisp Wed Nov 22 15:52:56 2006 @@ -108,10 +108,11 @@ (cond ((fad:directory-pathname-p original-pathname) (format t "~&Skipping directory ~A for now" modified-pathname) - ;; (let ((last-element (car (last (pathname-directory original-pathname))))) - ;; (unless (file-boring-p repo last-element) - ;; ;; We have a non-boring subdirectory. - ) + (let ((last-element (car (last (pathname-directory original-pathname))))) + (unless (file-boring-p repo last-element) + ;; We have a non-boring subdirectory. + (setf patches (nconc patches + (diff-repo repo original-pathname modified-pathname)))))) ((file-binary-p repo pathname-string) (setf patches (nconc patches

1 0

[Cl-darcs-cvs] r70 - cl-darcs/trunk
by mhenoch＠common-lisp.net 22 Nov '06

22 Nov '06

Author: mhenoch Date: Wed Nov 22 15:45:32 2006 New Revision: 70 Modified: cl-darcs/trunk/diff.lisp Log: Add diff-binary-file and use it Modified: cl-darcs/trunk/diff.lisp ============================================================================== --- cl-darcs/trunk/diff.lisp (original) +++ cl-darcs/trunk/diff.lisp Wed Nov 22 15:45:32 2006 @@ -56,6 +56,32 @@ (nreverse patches))) +(defun diff-binary-file (original modified &key filename) + "Find changes between binary files ORIGINAL and MODIFIED. +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))))))) + (defun diff-repo (repo &optional original modified) "Find changes in REPO from pristine tree. Return a list of patches. @@ -88,7 +114,10 @@ ) ((file-binary-p repo pathname-string) - (format t "~&Skipping binary file ~A for now" modified-pathname)) + (setf patches (nconc patches + (diff-binary-file original-pathname + modified-pathname + :filename pathname-string)))) (t (setf patches (nconc patches

1 0

[Cl-darcs-cvs] r69 - cl-darcs/trunk
by mhenoch＠common-lisp.net 22 Nov '06

22 Nov '06

Author: mhenoch Date: Wed Nov 22 15:34:51 2006 New Revision: 69 Modified: cl-darcs/trunk/diff.lisp Log: Skip binary files in diff-repo for now Modified: cl-darcs/trunk/diff.lisp ============================================================================== --- cl-darcs/trunk/diff.lisp (original) +++ cl-darcs/trunk/diff.lisp Wed Nov 22 15:34:51 2006 @@ -74,22 +74,26 @@ (modified-wild (merge-pathnames wild modified)) patches) (dolist (original-pathname (fad:list-directory original)) - (let ((relative-pathname - (translate-pathname original-pathname original-wild repo-wild)) + (let ((pathname-string + (pathname-to-string + (translate-pathname original-pathname original-wild repo-wild))) (modified-pathname (translate-pathname original-pathname original-wild modified-wild))) (cond ((fad:directory-pathname-p original-pathname) - (format t "~&Skipping directory ~A for now" original-pathname) + (format t "~&Skipping directory ~A for now" modified-pathname) ;; (let ((last-element (car (last (pathname-directory original-pathname))))) ;; (unless (file-boring-p repo last-element) ;; ;; We have a non-boring subdirectory. ) + + ((file-binary-p repo pathname-string) + (format t "~&Skipping binary file ~A for now" modified-pathname)) + (t (setf patches (nconc patches (diff-file original-pathname modified-pathname - :filename - (pathname-to-string relative-pathname)))))))) + :filename pathname-string))))))) patches))

1 0

[Cl-darcs-cvs] r68 - cl-darcs/trunk
by mhenoch＠common-lisp.net 22 Nov '06

22 Nov '06

Author: mhenoch Date: Wed Nov 22 15:30:46 2006 New Revision: 68 Modified: cl-darcs/trunk/diff.lisp Log: Add diff-repo Modified: cl-darcs/trunk/diff.lisp ============================================================================== --- cl-darcs/trunk/diff.lisp (original) +++ cl-darcs/trunk/diff.lisp Wed Nov 22 15:30:46 2006 @@ -55,3 +55,41 @@ patches))) (nreverse patches))) + +(defun diff-repo (repo &optional original modified) + "Find changes in REPO from pristine tree. +Return a list of patches. +ORIGINAL and MODIFIED specify directories to start from." + (setf repo (fad:pathname-as-directory repo)) + (unless (and original modified) + (setf modified repo) + (setf original (upath-subdir repo '("_darcs" "pristine")))) + + (let* ((wild (make-pathname :directory '(:relative :wild-inferiors) + :name :wild + :type :wild + :version :wild)) + (repo-wild (merge-pathnames wild repo)) + (original-wild (merge-pathnames wild original)) + (modified-wild (merge-pathnames wild modified)) + patches) + (dolist (original-pathname (fad:list-directory original)) + (let ((relative-pathname + (translate-pathname original-pathname original-wild repo-wild)) + (modified-pathname + (translate-pathname original-pathname original-wild modified-wild))) + (cond + ((fad:directory-pathname-p original-pathname) + (format t "~&Skipping directory ~A for now" original-pathname) + ;; (let ((last-element (car (last (pathname-directory original-pathname))))) + ;; (unless (file-boring-p repo last-element) + ;; ;; We have a non-boring subdirectory. + ) + (t + (setf patches (nconc patches + (diff-file original-pathname + modified-pathname + :filename + (pathname-to-string relative-pathname)))))))) + + patches))

1 0

[Cl-darcs-cvs] r67 - cl-darcs/trunk
by mhenoch＠common-lisp.net 22 Nov '06

22 Nov '06

Author: mhenoch Date: Wed Nov 22 15:00:24 2006 New Revision: 67 Added: cl-darcs/trunk/diff.lisp Modified: cl-darcs/trunk/cl-darcs.asd Log: Start hacking diff Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Wed Nov 22 15:00:24 2006 @@ -21,7 +21,9 @@ ;; Files and directories :cl-fad ;; Regexps - :cl-ppcre) + :cl-ppcre + ;; Diff + :cl-difflib) :components ((:file "packages") Added: cl-darcs/trunk/diff.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/diff.lisp Wed Nov 22 15:00:24 2006 @@ -0,0 +1,57 @@ +;;; 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 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)) + (let* ((original-lines + (with-open-stream (in (open-upath original :binary t)) + (loop for line = (read-binary-line in nil) + while line collect line))) + (modified-lines + (with-open-stream (in (open-upath modified :binary t)) + (loop for line = (read-binary-line in nil) + while line collect line))) + + ;; using equalp is safe (i.e. non-case-clobbering), as + ;; we use bytes instead of characters + (opcodes (difflib:get-opcodes + (make-instance 'difflib:sequence-matcher + :a original-lines + :b modified-lines + :test-function #'equalp))) + + patches) + + (dolist (opcode opcodes) + (unless (eql (difflib:opcode-tag opcode) :equal) + (push + (make-instance 'hunk-patch + :filename filename + :line-number (difflib:opcode-j1 opcode) + :old (subseq original-lines + (difflib:opcode-i1 opcode) + (difflib:opcode-i2 opcode)) + :new (subseq modified-lines + (difflib:opcode-j1 opcode) + (difflib:opcode-j2 opcode))) + patches))) + + (nreverse patches)))

1 0

[Cl-darcs-cvs] r66 - cl-darcs/trunk
by mhenoch＠common-lisp.net 22 Nov '06

22 Nov '06

Author: mhenoch Date: Wed Nov 22 13:46:37 2006 New Revision: 66 Modified: cl-darcs/trunk/util.lisp Log: Add *scanner-cache*, matches-one-of, file-binary-p and file-boring-p. Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Wed Nov 22 13:46:37 2006 @@ -274,3 +274,30 @@ (copy-directory source-file target-file :excluding excluding)) (t (fad:copy-file source-file target-file))))))) + +(defvar *scanner-cache* (make-hash-table :test 'equal) + "Hash table for scanners created for filename regexp tests. +Creating a scanner is slow, but using it is fast.") + +(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))))) + +(defun file-binary-p (repo filename) + "Return true if FILENAME names a binary file. +Uses the regexps specified in REPO." + (let ((binary-regexps (get-preflist repo "binaries"))) + (matches-one-of binary-regexps filename))) + +(defun file-boring-p (repo filename) + "Return true if FILENAME names a boring file. +Uses the regexps specified in REPO." + (let ((binary-regexps (get-preflist repo "boring"))) + (matches-one-of binary-regexps filename)))

1 0

[Cl-darcs-cvs] r65 - cl-darcs/trunk
by mhenoch＠common-lisp.net 01 Nov '06

01 Nov '06

Author: mhenoch Date: Tue Oct 31 19:39:23 2006 New Revision: 65 Modified: cl-darcs/trunk/cl-darcs.asd Log: Add dependency on cl-ppcre Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Tue Oct 31 19:39:23 2006 @@ -19,7 +19,9 @@ ;; Ironclad's SHA1 doesn't work with CLISP yet #+clisp :sb-sha1 ;; Files and directories - :cl-fad) + :cl-fad + ;; Regexps + :cl-ppcre) :components ((:file "packages")

1 0