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

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

27 Nov '06

Author: mhenoch Date: Mon Nov 27 17:50:51 2006 New Revision: 77 Added: cl-darcs/trunk/record.lisp Modified: cl-darcs/trunk/cl-darcs.asd Log: Add record.lisp Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Mon Nov 27 17:50:51 2006 @@ -38,6 +38,7 @@ (:file "prefs" :depends-on ("util")) (:file "repo" :depends-on ("util")) (:file "diff" :depends-on ("util")) + (:file "record" :depends-on ("util")) (:file "patch-core" :depends-on ("util")) (:file "read-patch" :depends-on ("patch-core")) Added: cl-darcs/trunk/record.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/record.lisp Mon Nov 27 17:50:51 2006 @@ -0,0 +1,54 @@ +;;; 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 record-patches (repo name author date log patches) + "Record PATCHES in REPO. +NAME is the name of the patch, a description of one line. +AUTHOR is the e-mail address (or other identifier) of the author. +DATE is the date in YYYYMMDDHHMMSS format, or the keyword :NOW. +LOG is either NIL or a possibly multi-line description of the patch. +PATCHES is a list of patches that make up the change." + (let* ((patchinfo + (make-patchinfo + :name name :author author + :date (if (eql date :now) + (multiple-value-bind + (second minute hour date month year) + (get-decoded-time) + (format nil "~4,'0d~2,'0d~2,'0d~2,'0d~2,'0d~2,'0d" + year month date hour minute second)) + date) + :log (split-sequence:split-sequence #\Newline log))) + (patch (make-instance 'named-patch + :patchinfo patchinfo + :dependencies nil + :patch + (make-instance 'composite-patch + :patches patches)))) + (write-patch-to-repo patch repo) + (apply-patch-to-pristine patch repo) + (append-inventory repo patchinfo))) + +(defun record-changes (repo name author date log) + "Record changes in REPO. +Arguments as to `record-patches'." + (let ((patches (diff-repo repo))) + (unless patches + (error "Nothing to record.")) + + (record-patches repo name author date log patches)))

1 0

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

27 Nov '06

Author: mhenoch Date: Mon Nov 27 17:26:00 2006 New Revision: 76 Modified: cl-darcs/trunk/diff.lisp Log: Darcs line numbers start at 1. Modified: cl-darcs/trunk/diff.lisp ============================================================================== --- cl-darcs/trunk/diff.lisp (original) +++ cl-darcs/trunk/diff.lisp Mon Nov 27 17:26:00 2006 @@ -77,7 +77,7 @@ (push (make-instance 'hunk-patch :filename filename - :line-number (difflib:opcode-j1 opcode) + :line-number (1+ (difflib:opcode-j1 opcode)) :old (subseq original-lines (difflib:opcode-i1 opcode) (difflib:opcode-i2 opcode))

1 0

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

27 Nov '06

Author: mhenoch Date: Mon Nov 27 16:42:25 2006 New Revision: 75 Modified: cl-darcs/trunk/cl-darcs.asd Log: Include diff.lisp in ASDF file Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Mon Nov 27 16:42:25 2006 @@ -37,6 +37,7 @@ (:file "init" :depends-on ("util")) (:file "prefs" :depends-on ("util")) (:file "repo" :depends-on ("util")) + (:file "diff" :depends-on ("util")) (:file "patch-core" :depends-on ("util")) (:file "read-patch" :depends-on ("patch-core"))

1 0

[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