From mhenoch at common-lisp.net Wed Nov 1 00:34:21 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Tue, 31 Oct 2006 19:34:21 -0500 (EST) Subject: [Cl-darcs-cvs] r62 - cl-darcs/trunk Message-ID: <20061101003421.1C4B03903C@common-lisp.net> Author: mhenoch Date: Tue Oct 31 19:34:20 2006 New Revision: 62 Modified: cl-darcs/trunk/upath.lisp Log: Change package references from PURI to NET.URI. Makes the code work on ACL, and that is a nickname for the PURI package anyway. Modified: cl-darcs/trunk/upath.lisp ============================================================================== --- cl-darcs/trunk/upath.lisp (original) +++ cl-darcs/trunk/upath.lisp Tue Oct 31 19:34:20 2006 @@ -18,7 +18,7 @@ ;; "Universal pathname" - can refer to either a local or a remote ;; file. For local files, just use pathnames. For remote files, use -;; the PURI library. +;; the PURI library. (Or the real thing, if we're using ACL) (defun make-upath (path) "Turn PATH into a \"universal pathname\". @@ -28,12 +28,12 @@ (ctypecase path (pathname path) - (puri:uri + (net.uri:uri path) (string (if (or (string= path "http://" :end1 7) (string= path "https://" :end1 8)) - (puri:parse-uri path) + (net.uri:parse-uri path) (pathname path))))) (defun upath-subdir (base subdirs &optional filename) @@ -44,16 +44,16 @@ (pathname-directory subdirs) subdirs)))) (ctypecase base - (puri:uri - (let* ((current-path (puri:uri-parsed-path base)) + (net.uri:uri + (let* ((current-path (net.uri:uri-parsed-path base)) (new-path (cond ((null current-path) (cons :absolute subdirs-list)) (t (append current-path subdirs-list)))) - (new-uri (puri:copy-uri base))) - (setf (puri:uri-parsed-path new-uri) (if filename + (new-uri (net.uri:copy-uri base))) + (setf (net.uri:uri-parsed-path new-uri) (if filename (append new-path (list filename)) new-path)) new-uri)) @@ -70,7 +70,7 @@ else CHARACTER." (setf upath (make-upath upath)) (ctypecase upath - (puri:uri + (net.uri:uri (dformat "~&Opening ~A..." upath) (let ((client-request (net.aserve.client:make-http-client-request upath :proxy *http-proxy*))) (net.aserve.client:read-client-response-headers client-request) @@ -84,7 +84,7 @@ (dformat "~&Redirected to ~A." new-location) (net.aserve.client:client-request-close client-request) (open-upath - (puri:uri new-location) + (net.uri:uri new-location) :redirect-max-depth (1- redirect-max-depth) :binary binary))) (t (error "Couldn't read ~A: ~A ~A." From mhenoch at common-lisp.net Wed Nov 1 00:35:29 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Tue, 31 Oct 2006 19:35:29 -0500 (EST) Subject: [Cl-darcs-cvs] r63 - cl-darcs/trunk Message-ID: <20061101003529.E1256391A6@common-lisp.net> Author: mhenoch Date: Tue Oct 31 19:35:28 2006 New Revision: 63 Modified: cl-darcs/trunk/cl-darcs.asd Log: Load INFLATE through REQUIRE on ACL Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Tue Oct 31 19:35:28 2006 @@ -49,3 +49,7 @@ ;; Franz' inflate implementation #-allegro (:file "ifstar") #-allegro (:file "inflate" :depends-on ("ifstar")))) + +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :inflate)) From mhenoch at common-lisp.net Wed Nov 1 00:37:45 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Tue, 31 Oct 2006 19:37:45 -0500 (EST) Subject: [Cl-darcs-cvs] r64 - cl-darcs/trunk Message-ID: <20061101003745.D0FEB3C005@common-lisp.net> Author: mhenoch Date: Tue Oct 31 19:37:45 2006 New Revision: 64 Modified: cl-darcs/trunk/pull.lisp Log: Use PATCHINFO instead of PI in lambda functions. Modified: cl-darcs/trunk/pull.lisp ============================================================================== --- cl-darcs/trunk/pull.lisp (original) +++ cl-darcs/trunk/pull.lisp Tue Oct 31 19:37:45 2006 @@ -36,12 +36,12 @@ ;; XXX: This is where we pick which of their patches we want to ;; pull. (let* ((their-patches - (mapcar (lambda (pi) - (read-patch-from-repo theirrepo pi)) + (mapcar (lambda (patchinfo) + (read-patch-from-repo theirrepo patchinfo)) only-theirs)) (our-patches - (mapcar (lambda (pi) - (read-patch-from-repo ourrepo pi)) + (mapcar (lambda (patchinfo) + (read-patch-from-repo ourrepo patchinfo)) only-ours)) (merged-patches (patches (merge-patches (make-instance 'composite-patch From mhenoch at common-lisp.net Wed Nov 1 00:39:24 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Tue, 31 Oct 2006 19:39:24 -0500 (EST) Subject: [Cl-darcs-cvs] r65 - cl-darcs/trunk Message-ID: <20061101003924.28FE33C005@common-lisp.net> 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") From mhenoch at common-lisp.net Wed Nov 22 18:46:39 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 22 Nov 2006 13:46:39 -0500 (EST) Subject: [Cl-darcs-cvs] r66 - cl-darcs/trunk Message-ID: <20061122184639.D261C33002@common-lisp.net> 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))) From mhenoch at common-lisp.net Wed Nov 22 20:00:24 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 22 Nov 2006 15:00:24 -0500 (EST) Subject: [Cl-darcs-cvs] r67 - cl-darcs/trunk Message-ID: <20061122200024.A60CF48143@common-lisp.net> 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))) From mhenoch at common-lisp.net Wed Nov 22 20:30:46 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 22 Nov 2006 15:30:46 -0500 (EST) Subject: [Cl-darcs-cvs] r68 - cl-darcs/trunk Message-ID: <20061122203046.A494B4C0C3@common-lisp.net> 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)) From mhenoch at common-lisp.net Wed Nov 22 20:34:53 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 22 Nov 2006 15:34:53 -0500 (EST) Subject: [Cl-darcs-cvs] r69 - cl-darcs/trunk Message-ID: <20061122203453.7CD2F751A1@common-lisp.net> 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)) From mhenoch at common-lisp.net Wed Nov 22 20:45:33 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 22 Nov 2006 15:45:33 -0500 (EST) Subject: [Cl-darcs-cvs] r70 - cl-darcs/trunk Message-ID: <20061122204533.0ACB019008@common-lisp.net> 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 From mhenoch at common-lisp.net Wed Nov 22 20:52:56 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 22 Nov 2006 15:52:56 -0500 (EST) Subject: [Cl-darcs-cvs] r71 - cl-darcs/trunk Message-ID: <20061122205256.8A9661C008@common-lisp.net> 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 From mhenoch at common-lisp.net Wed Nov 22 20:54:41 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 22 Nov 2006 15:54:41 -0500 (EST) Subject: [Cl-darcs-cvs] r72 - cl-darcs/trunk Message-ID: <20061122205441.D54751C008@common-lisp.net> 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) From mhenoch at common-lisp.net Wed Nov 22 21:56:23 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 22 Nov 2006 16:56:23 -0500 (EST) Subject: [Cl-darcs-cvs] r73 - cl-darcs/trunk Message-ID: <20061122215623.C32173001D@common-lisp.net> 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*)) From mhenoch at common-lisp.net Mon Nov 27 21:41:32 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Mon, 27 Nov 2006 16:41:32 -0500 (EST) Subject: [Cl-darcs-cvs] r74 - cl-darcs/trunk Message-ID: <20061127214132.E778F2201A@common-lisp.net> 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)))) From mhenoch at common-lisp.net Mon Nov 27 21:42:25 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Mon, 27 Nov 2006 16:42:25 -0500 (EST) Subject: [Cl-darcs-cvs] r75 - cl-darcs/trunk Message-ID: <20061127214225.55EBE2201A@common-lisp.net> 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")) From mhenoch at common-lisp.net Mon Nov 27 22:26:00 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Mon, 27 Nov 2006 17:26:00 -0500 (EST) Subject: [Cl-darcs-cvs] r76 - cl-darcs/trunk Message-ID: <20061127222600.658E8A0F6@common-lisp.net> 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)) From mhenoch at common-lisp.net Mon Nov 27 22:50:52 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Mon, 27 Nov 2006 17:50:52 -0500 (EST) Subject: [Cl-darcs-cvs] r77 - cl-darcs/trunk Message-ID: <20061127225052.036291E002@common-lisp.net> 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))) From mhenoch at common-lisp.net Mon Nov 27 23:31:02 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Mon, 27 Nov 2006 18:31:02 -0500 (EST) Subject: [Cl-darcs-cvs] r78 - cl-darcs/trunk Message-ID: <20061127233102.508A734000@common-lisp.net> Author: mhenoch Date: Mon Nov 27 18:31:02 2006 New Revision: 78 Modified: cl-darcs/trunk/record.lisp Log: Add select-patches and use it Modified: cl-darcs/trunk/record.lisp ============================================================================== --- cl-darcs/trunk/record.lisp (original) +++ cl-darcs/trunk/record.lisp Mon Nov 27 18:31:02 2006 @@ -51,4 +51,47 @@ (unless patches (error "Nothing to record.")) - (record-patches repo name author date log patches))) + (record-patches repo name author date log (select-patches patches)))) + +(defun select-patches (patches) + "Ask the user to select some of PATCHES. +Do the necessary commutation and dependency elimination." + (let (patches-to-record) + (loop while (setf patches (remove nil patches)) + do + ;; Should we include this patch? + (if (y-or-n-p "Record patch ~A?" (car patches)) + (progn + ;; Yes, just add it to the list and go on. + (push (car patches) patches-to-record) + (setf patches (cdr patches))) + ;; No, we need to commute it through the rest of the patches. + (loop for commute-patches on (cdr patches) + ;; Try to commute it with the next patch in line. + do (let ((commute-result (commute (car commute-patches) (car patches)))) + (if commute-result + ;; Commutation succeeded; use the altered patches. + (destructuring-bind (commuted-current commuted-future) commute-result + (setf (car patches) commuted-current) + (setf (car commute-patches) commuted-future)) + ;; Commutation failed; (car commute-patches) depends on (car patches). + ;; Try to commute them together. + (progn + ;; Turn the patch we are commuting through + ;; the list into a composite patch, unless it is + ;; one already. Append the dependency. + (etypecase (car patches) + (composite-patch + (nconc (patches (car patches)) + (list (car commute-patches)))) + (patch + (setf (car patches) + (make-instance 'composite-patch + :patches (list + (car patches) + (car commute-patches)))))) + ;; Drop the dependency from the list of + ;; patches to consider. + (setf (car commute-patches) nil)))) + finally (setf patches (cdr patches))))) + (nreverse patches-to-record))) From mhenoch at common-lisp.net Mon Nov 27 23:31:59 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Mon, 27 Nov 2006 18:31:59 -0500 (EST) Subject: [Cl-darcs-cvs] r79 - cl-darcs/trunk Message-ID: <20061127233159.AD70334000@common-lisp.net> Author: mhenoch Date: Mon Nov 27 18:31:58 2006 New Revision: 79 Modified: cl-darcs/trunk/packages.lisp Log: Export record-patches Modified: cl-darcs/trunk/packages.lisp ============================================================================== --- cl-darcs/trunk/packages.lisp (original) +++ cl-darcs/trunk/packages.lisp Mon Nov 27 18:31:58 2006 @@ -4,4 +4,5 @@ (:use :cl) (:nicknames :cl-darcs) (:export - #:get-repo #:pull #:diff-repo #:*http-proxy*)) + #:get-repo #:pull #:diff-repo #:*http-proxy* + #:record-patches)) From mhenoch at common-lisp.net Mon Nov 27 23:48:08 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Mon, 27 Nov 2006 18:48:08 -0500 (EST) Subject: [Cl-darcs-cvs] r80 - cl-darcs/trunk Message-ID: <20061127234808.175FC53102@common-lisp.net> Author: mhenoch Date: Mon Nov 27 18:48:08 2006 New Revision: 80 Modified: cl-darcs/trunk/README Log: Mention record-changes in README Modified: cl-darcs/trunk/README ============================================================================== --- cl-darcs/trunk/README (original) +++ cl-darcs/trunk/README Mon Nov 27 18:48:08 2006 @@ -22,12 +22,19 @@ or (darcs:pull "/local/repo-dir/" "http://path/to/repo") -cl-darcs currently doesn't try to merge changes in your local tree -with patches you pull; you have to do that manually if you want to -edit files. For now, you need an external tool to find the local -changes, e.g: +When pulling, the new patches will be applied on top of any unrecorded +changes, which has a good chance of not working. -diff -x _darcs -ru _darcs/pristine/ . +To record your own changes: + +(darcs:record-changes "/local/repo-dir/" + "Short patch description" + "my-address at example.com" + :now + "Longer, possibly multi-line, description. +Or just NIL.") + +You will be asked about which changes should be recorded. * Configuration From mhenoch at common-lisp.net Tue Nov 28 00:15:22 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Mon, 27 Nov 2006 19:15:22 -0500 (EST) Subject: [Cl-darcs-cvs] r81 - cl-darcs/trunk Message-ID: <20061128001522.096BE702E8@common-lisp.net> Author: mhenoch Date: Mon Nov 27 19:15:21 2006 New Revision: 81 Added: cl-darcs/trunk/display-patch.lisp Modified: cl-darcs/trunk/cl-darcs.asd Log: Add display-patch.lisp Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Mon Nov 27 19:15:21 2006 @@ -45,6 +45,7 @@ (:file "write-patch" :depends-on ("patch-core")) (:file "apply-patch" :depends-on ("patch-core")) (:file "invert-patch" :depends-on ("patch-core")) + (:file "display-patch" :depends-on ("patch-core")) (:file "pristine" :depends-on ("patch-core")) (:file "touching" :depends-on ("patch-core")) (:file "commute" :depends-on ("patch-core")) Added: cl-darcs/trunk/display-patch.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/display-patch.lisp Mon Nov 27 19:15:21 2006 @@ -0,0 +1,36 @@ +;;; 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) + +(defgeneric display-patch (patch stream) + (:documentation + "Print an elaborate and readable description of PATCH to STREAM.")) + +(defmethod display-patch ((patch patch) stream) + "When no display method is defined, write a terse description." + (print patch stream)) + +(defmethod display-patch ((patch hunk-patch) stream) + (format stream "~&~A: ~A~[~:;~:*-~A~]~[~:;~:*+~A~]" + (patch-filename patch) + (hunk-line-number patch) + (length (hunk-old-lines patch)) + (length (hunk-new-lines patch))) + (dolist (old (hunk-old-lines patch)) + (format stream "~&-~A" (bytes-to-string old))) + (dolist (new (hunk-new-lines patch)) + (format stream "~&+~A" (bytes-to-string new)))) From mhenoch at common-lisp.net Tue Nov 28 00:29:54 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Mon, 27 Nov 2006 19:29:54 -0500 (EST) Subject: [Cl-darcs-cvs] r82 - cl-darcs/trunk Message-ID: <20061128002954.5434B710F9@common-lisp.net> Author: mhenoch Date: Mon Nov 27 19:29:54 2006 New Revision: 82 Modified: cl-darcs/trunk/record.lisp Log: Display patches before asking whether to record them. Handle recording with empty log message. Modified: cl-darcs/trunk/record.lisp ============================================================================== --- cl-darcs/trunk/record.lisp (original) +++ cl-darcs/trunk/record.lisp Mon Nov 27 19:29:54 2006 @@ -33,7 +33,8 @@ (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))) + :log (when log + (split-sequence:split-sequence #\Newline log)))) (patch (make-instance 'named-patch :patchinfo patchinfo :dependencies nil @@ -60,6 +61,7 @@ (loop while (setf patches (remove nil patches)) do ;; Should we include this patch? + (display-patch (car patches) *query-io*) (if (y-or-n-p "Record patch ~A?" (car patches)) (progn ;; Yes, just add it to the list and go on. From mhenoch at common-lisp.net Tue Nov 28 01:36:32 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Mon, 27 Nov 2006 20:36:32 -0500 (EST) Subject: [Cl-darcs-cvs] r83 - cl-darcs/trunk Message-ID: <20061128013632.534C61C0BA@common-lisp.net> Author: mhenoch Date: Mon Nov 27 20:36:32 2006 New Revision: 83 Modified: cl-darcs/trunk/get.lisp cl-darcs/trunk/packages.lisp Log: Add and export create-repo Modified: cl-darcs/trunk/get.lisp ============================================================================== --- cl-darcs/trunk/get.lisp (original) +++ cl-darcs/trunk/get.lisp Mon Nov 27 20:36:32 2006 @@ -16,6 +16,12 @@ (in-package :darcs) +(defun create-repo (repodir) + "Create an empty repository." + (setf repodir (fad:pathname-as-directory repodir)) + (prepare-new-repo repodir) + (create-pristine-from-tree repodir)) + ;; get_cmd in Get.lhs (defun get-repo (inrepodir outname &key (partial nil) (query nil)) (setf outname (fad:pathname-as-directory outname)) Modified: cl-darcs/trunk/packages.lisp ============================================================================== --- cl-darcs/trunk/packages.lisp (original) +++ cl-darcs/trunk/packages.lisp Mon Nov 27 20:36:32 2006 @@ -5,4 +5,4 @@ (:nicknames :cl-darcs) (:export #:get-repo #:pull #:diff-repo #:*http-proxy* - #:record-patches)) + #:record-patches #:create-repo)) From mhenoch at common-lisp.net Tue Nov 28 01:36:54 2006 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Mon, 27 Nov 2006 20:36:54 -0500 (EST) Subject: [Cl-darcs-cvs] r84 - cl-darcs/trunk Message-ID: <20061128013654.745921C0B9@common-lisp.net> Author: mhenoch Date: Mon Nov 27 20:36:54 2006 New Revision: 84 Modified: cl-darcs/trunk/packages.lisp Log: Export record-changes instead of record-patches Modified: cl-darcs/trunk/packages.lisp ============================================================================== --- cl-darcs/trunk/packages.lisp (original) +++ cl-darcs/trunk/packages.lisp Mon Nov 27 20:36:54 2006 @@ -5,4 +5,4 @@ (:nicknames :cl-darcs) (:export #:get-repo #:pull #:diff-repo #:*http-proxy* - #:record-patches #:create-repo)) + #:record-changes #:create-repo))