From mhenoch at common-lisp.net Wed Aug 22 00:37:22 2007 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Tue, 21 Aug 2007 20:37:22 -0400 (EDT) Subject: [Cl-darcs-cvs] r119 - cl-darcs/trunk Message-ID: <20070822003722.BDD6561061@common-lisp.net> Author: mhenoch Date: Tue Aug 21 20:37:22 2007 New Revision: 119 Modified: cl-darcs/trunk/send.lisp Log: Use MAKE-ARRAY instead of COERCE Modified: cl-darcs/trunk/send.lisp ============================================================================== --- cl-darcs/trunk/send.lisp (original) +++ cl-darcs/trunk/send.lisp Tue Aug 21 20:37:22 2007 @@ -103,7 +103,9 @@ (dolist (patch patches) (write-patch patch out))))) (setf patches-as-vector - (coerce patches-as-vector '(simple-array (unsigned-byte 8)))) + (make-array (length patches-as-vector) + :element-type '(unsigned-byte 8) + :initial-contents patches-as-vector)) (ironclad:byte-array-to-hex-string #+clisp (sb-sha1:sha1sum-sequence patches-as-vector) #-clisp (ironclad:digest-sequence :sha1 patches-as-vector)))) From mhenoch at common-lisp.net Wed Aug 22 02:00:49 2007 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Tue, 21 Aug 2007 22:00:49 -0400 (EDT) Subject: [Cl-darcs-cvs] r120 - cl-darcs/trunk Message-ID: <20070822020049.C56314507D@common-lisp.net> Author: mhenoch Date: Tue Aug 21 22:00:48 2007 New Revision: 120 Modified: cl-darcs/trunk/apply-patch.lisp Log: For Lispworks, use RENAME-FILE when applying a MOVE-PATCH. Suggestion by Jochen Schmidt. Signal an error if the Lisp implementation is unsupported. Partial fix for #2. Modified: cl-darcs/trunk/apply-patch.lisp ============================================================================== --- cl-darcs/trunk/apply-patch.lisp (original) +++ cl-darcs/trunk/apply-patch.lisp Tue Aug 21 22:00:48 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 @@ -169,7 +169,13 @@ :search t) #+clisp (let ((result (ext:run-program "mv" :arguments (list (namestring from) (namestring to))))) (unless (eql result 0) - (error "Couldn't move ~A to ~A." from to))))) + (error "Couldn't move ~A to ~A." from to))) + + ;; In Lispworks, this works for both files and directories. + #+lispworks (rename-file from to) + + #-(or clisp sbcl lispworks) + (error "Applying a MOVE-PATCH is not implemented for ~A." (lisp-implementation-type)))) (defmethod apply-patch ((patch token-replace-patch) repodir) "Apply a token replace patch to a file in REPODIR." From mhenoch at common-lisp.net Fri Aug 24 03:38:04 2007 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Thu, 23 Aug 2007 23:38:04 -0400 (EDT) Subject: [Cl-darcs-cvs] r121 - cl-darcs/trunk Message-ID: <20070824033804.F2D78431B7@common-lisp.net> Author: mhenoch Date: Thu Aug 23 23:38:04 2007 New Revision: 121 Modified: cl-darcs/trunk/cl-darcs.asd cl-darcs/trunk/patchinfo.lisp cl-darcs/trunk/send.lisp Log: Ironclad's SHA1 works with CLISP now Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Thu Aug 23 23:38:04 2007 @@ -17,8 +17,6 @@ ;; SHA1, hex etc :ironclad :flexi-streams - ;; Ironclad's SHA1 doesn't work with CLISP yet - #+clisp :sb-sha1 ;; Files and directories :cl-fad ;; Regexps Modified: cl-darcs/trunk/patchinfo.lisp ============================================================================== --- cl-darcs/trunk/patchinfo.lisp (original) +++ cl-darcs/trunk/patchinfo.lisp Thu Aug 23 23:38:04 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 @@ -24,8 +24,7 @@ (defun patchinfo-make-filename (patchinfo) (with-slots (date name author log inverted) patchinfo (labels ((sha1-internal (bytes) - #+clisp (sb-sha1:sha1sum-sequence bytes) - #-clisp (ironclad:digest-sequence :sha1 bytes)) + (ironclad:digest-sequence :sha1 bytes)) (sha1 (str) (ironclad:byte-array-to-hex-string (sha1-internal Modified: cl-darcs/trunk/send.lisp ============================================================================== --- cl-darcs/trunk/send.lisp (original) +++ cl-darcs/trunk/send.lisp Thu Aug 23 23:38:04 2007 @@ -107,5 +107,4 @@ :element-type '(unsigned-byte 8) :initial-contents patches-as-vector)) (ironclad:byte-array-to-hex-string - #+clisp (sb-sha1:sha1sum-sequence patches-as-vector) - #-clisp (ironclad:digest-sequence :sha1 patches-as-vector)))) + (ironclad:digest-sequence :sha1 patches-as-vector)))) From mhenoch at common-lisp.net Fri Aug 24 04:34:11 2007 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Fri, 24 Aug 2007 00:34:11 -0400 (EDT) Subject: [Cl-darcs-cvs] r122 - cl-darcs/trunk Message-ID: <20070824043411.292F07E00F@common-lisp.net> Author: mhenoch Date: Fri Aug 24 00:34:10 2007 New Revision: 122 Modified: cl-darcs/trunk/repo.lisp Log: Add functions for managing pending patches Modified: cl-darcs/trunk/repo.lisp ============================================================================== --- cl-darcs/trunk/repo.lisp (original) +++ cl-darcs/trunk/repo.lisp Fri Aug 24 00:34: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 @@ -162,3 +162,24 @@ (values (intersection ours-list theirs-list :test #'equalp) (set-difference ours-list theirs-list :test #'equalp) (set-difference theirs-list ours-list :test #'equalp)))) + +(defun pending-filename (repodir) + "Get the name of the file containing \"pending\" patches for REPODIR." + (upath-subdir repodir '("_darcs" "patches") "pending")) + +(defun read-pending (repodir) + "Read the \"pending\" patches of REPODIR." + (let ((pending-file (pending-filename repodir))) + (when (probe-file pending-file) + (read-patch-from-file pending-file :compressed nil)))) + +(defun add-to-pending (repodir patch) + "Add PATCH to the list of \"pending\" patches in REPODIR." + (let ((pending (read-pending repodir))) + (when (null pending) + (setf pending (make-instance 'composite-patch))) + (setf (patches pending) (append (patches pending) (list patch))) + (with-open-file (out (pending-filename repodir) + :direction :output :element-type '(unsigned-byte 8) + :if-exists :supersede) + (write-patch pending out)))) From mhenoch at common-lisp.net Fri Aug 24 04:42:52 2007 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Fri, 24 Aug 2007 00:42:52 -0400 (EDT) Subject: [Cl-darcs-cvs] r123 - cl-darcs/trunk Message-ID: <20070824044252.C21E5A148@common-lisp.net> Author: mhenoch Date: Fri Aug 24 00:42:52 2007 New Revision: 123 Modified: cl-darcs/trunk/util.lisp Log: Add PATHNAME-SANE-P and use it. Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Fri Aug 24 00:42:52 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 @@ -225,10 +225,18 @@ (make-pathname :directory (cons :relative directory) :name filename-without-dot :type type)))))) +(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))))) + (defun pathname-to-string (pathname) "Convert PATHNAME to a string usable in darcs patch files. PATHNAME is assumed to be a relative pathname going strictly down, as returned by SANITIZE-FILENAME." + (assert (pathname-sane-p pathname)) (apply #'concatenate 'string "./" (append From mhenoch at common-lisp.net Fri Aug 24 05:05:54 2007 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Fri, 24 Aug 2007 01:05:54 -0400 (EDT) Subject: [Cl-darcs-cvs] r124 - cl-darcs/trunk Message-ID: <20070824050554.9E18726081@common-lisp.net> Author: mhenoch Date: Fri Aug 24 01:05:53 2007 New Revision: 124 Added: cl-darcs/trunk/pending.lisp Modified: cl-darcs/trunk/cl-darcs.asd cl-darcs/trunk/repo.lisp Log: Add ADD-FILE. Move "pending" functions to pending.lisp. Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Fri Aug 24 01:05:53 2007 @@ -53,6 +53,7 @@ (:file "equal" :depends-on ("patch-core")) (:file "send" :depends-on ("patch-core")) (:file "revert" :depends-on ("patch-core")) + (:file "pending" :depends-on ("patch-core")) ;; Franz' inflate implementation #-allegro (:file "ifstar") Added: cl-darcs/trunk/pending.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/pending.lisp Fri Aug 24 01:05:53 2007 @@ -0,0 +1,72 @@ +;;; Copyright (C) 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 +;;; 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 pending-filename (repodir) + "Get the name of the file containing \"pending\" patches for REPODIR." + (upath-subdir repodir '("_darcs" "patches") "pending")) + +(defun read-pending (repodir) + "Read the \"pending\" patches of REPODIR." + (let ((pending-file (pending-filename repodir))) + (when (probe-file pending-file) + (read-patch-from-file pending-file :compressed nil)))) + +(defun add-to-pending (repodir patch) + "Add PATCH to the list of \"pending\" patches in REPODIR." + (let ((pending (read-pending repodir))) + (when (null pending) + (setf pending (make-instance 'composite-patch))) + (setf (patches pending) (append (patches pending) (list patch))) + (with-open-file (out (pending-filename repodir) + :direction :output :element-type '(unsigned-byte 8) + :if-exists :supersede) + (write-patch pending out)))) + +(defun add-file (repo file) + "Schedule FILE for recording to REPO. +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 file)) + :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))) + (when (if (eql type :file) + (fad:file-exists-p pristine-file) + (fad:directory-exists-p pristine-file)) + (error "~A already exists in the repository." (pathname-to-string file))) + (when (not (if (eql type :file) + (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)))) + + (add-to-pending + repo + (if (eql type :file) + (make-instance 'add-file-patch :filename (pathname-to-string file)) + (make-instance 'add-dir-patch :directory (pathname-to-string file)))))) Modified: cl-darcs/trunk/repo.lisp ============================================================================== --- cl-darcs/trunk/repo.lisp (original) +++ cl-darcs/trunk/repo.lisp Fri Aug 24 01:05:53 2007 @@ -162,24 +162,3 @@ (values (intersection ours-list theirs-list :test #'equalp) (set-difference ours-list theirs-list :test #'equalp) (set-difference theirs-list ours-list :test #'equalp)))) - -(defun pending-filename (repodir) - "Get the name of the file containing \"pending\" patches for REPODIR." - (upath-subdir repodir '("_darcs" "patches") "pending")) - -(defun read-pending (repodir) - "Read the \"pending\" patches of REPODIR." - (let ((pending-file (pending-filename repodir))) - (when (probe-file pending-file) - (read-patch-from-file pending-file :compressed nil)))) - -(defun add-to-pending (repodir patch) - "Add PATCH to the list of \"pending\" patches in REPODIR." - (let ((pending (read-pending repodir))) - (when (null pending) - (setf pending (make-instance 'composite-patch))) - (setf (patches pending) (append (patches pending) (list patch))) - (with-open-file (out (pending-filename repodir) - :direction :output :element-type '(unsigned-byte 8) - :if-exists :supersede) - (write-patch pending out)))) From mhenoch at common-lisp.net Fri Aug 24 12:11:44 2007 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Fri, 24 Aug 2007 08:11:44 -0400 (EDT) Subject: [Cl-darcs-cvs] r125 - cl-darcs/trunk Message-ID: <20070824121144.7D114A248@common-lisp.net> Author: mhenoch Date: Fri Aug 24 08:11:44 2007 New Revision: 125 Modified: cl-darcs/trunk/pending.lisp Log: Don't convert pathname to string when creating patch objects Modified: cl-darcs/trunk/pending.lisp ============================================================================== --- cl-darcs/trunk/pending.lisp (original) +++ cl-darcs/trunk/pending.lisp Fri Aug 24 08:11:44 2007 @@ -68,5 +68,5 @@ (add-to-pending repo (if (eql type :file) - (make-instance 'add-file-patch :filename (pathname-to-string file)) - (make-instance 'add-dir-patch :directory (pathname-to-string file)))))) + (make-instance 'add-file-patch :filename file) + (make-instance 'add-dir-patch :directory file))))) From mhenoch at common-lisp.net Fri Aug 24 12:15:10 2007 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Fri, 24 Aug 2007 08:15:10 -0400 (EDT) Subject: [Cl-darcs-cvs] r126 - cl-darcs/trunk Message-ID: <20070824121510.6B0D02107F@common-lisp.net> Author: mhenoch Date: Fri Aug 24 08:15:10 2007 New Revision: 126 Modified: cl-darcs/trunk/touching.lisp Log: Make FIND-TOUCHING direction-aware Modified: cl-darcs/trunk/touching.lisp ============================================================================== --- cl-darcs/trunk/touching.lisp (original) +++ cl-darcs/trunk/touching.lisp Fri Aug 24 08:15: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 @@ -16,41 +16,74 @@ (in-package :cl-darcs) -(defgeneric find-touching (patch filename) +(defgeneric find-touching (patch filename direction) (:documentation "Find and return the subset of PATCH that touches FILENAME. -Return NIL if PATCH doesn't touch FILENAME at all.")) -(defmethod find-touching :around (patch (filename string)) - (find-touching patch (sanitize-filename filename))) +DIRECTION is either :FORWARDS or :BACKWARDS. If it is :FORWARDS, +FILENAME is the name of the file before this patch; if :BACKWARDS, +after. + +Two values are returned, the subset patch, and the new name of the +file. The subset patch is NIL if PATCH doesn't touch FILENAME at all. +The name is the same as the old one, if the patch didn't +change the file's name. The name is NIL if the file doesn't exist +before/after the patch, or if the patch doesn't touch the file.")) -(defmethod find-touching ((patch patch) filename) +(defmethod find-touching :around (patch (filename string) direction) + (find-touching patch (sanitize-filename filename) direction)) + +(defmethod find-touching ((patch patch) filename direction) "This least specific method returns NIL." - (declare (ignore filename)) + (declare (ignore filename direction)) nil) -(defmethod find-touching ((patch composite-patch) filename) +(defmethod find-touching ((patch composite-patch) filename direction) "Return a new composite patch containing those patches that touch FILENAME. Return nil if no patches do." - (let ((touching-patches - (loop for p in (patches patch) - when (find-touching p filename) - collect it))) + (let ((patches (ecase direction + (:forwards (patches patch)) + (:backwards (reverse (patches patch))))) + touching-patches) + (dolist (p patches) + (multiple-value-bind + (subset-patch new-name) + (find-touching p filename direction) + (when subset-patch + (push subset-patch touching-patches) + (setf filename new-name) + (when (null filename) + (return))))) (when touching-patches - (make-instance 'composite-patch :patches touching-patches)))) + (make-instance 'composite-patch :patches (nreverse touching-patches))))) -(defmethod find-touching ((patch file-patch) filename) +(defmethod find-touching ((patch file-patch) filename direction) + (declare (ignore direction)) (when (equal filename (patch-filename patch)) - patch)) + (values patch filename))) -(defmethod find-touching ((patch directory-patch) filename) +(defmethod find-touching ((patch directory-patch) filename direction) + (declare (ignore direction)) (when (equal filename (patch-directory patch)) - patch)) + (values patch filename))) -(defmethod find-touching ((patch named-patch) filename) - (let ((touching-patch (find-touching (named-patch-patch patch) filename))) +(defmethod find-touching ((patch named-patch) filename direction) + (multiple-value-bind (touching-patch new-name) + (find-touching (named-patch-patch patch) filename direction) (when touching-patch - (make-instance 'named-patch - :patchinfo (named-patch-patchinfo patch) - :dependencies (named-patch-dependencies patch) - :patch touching-patch)))) - + (values + (make-instance 'named-patch + :patchinfo (named-patch-patchinfo patch) + :dependencies (named-patch-dependencies patch) + :patch touching-patch) + new-name)))) + +(defmethod find-touching ((patch move-patch) filename direction) + (let ((from (patch-move-from patch)) + (to (patch-move-to patch))) + (ecase direction + (:forwards + (when (equal filename from) + (values patch to))) + (:backwards + (when (equal filename to) + (values patch from)))))) From mhenoch at common-lisp.net Fri Aug 24 12:25:39 2007 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Fri, 24 Aug 2007 08:25:39 -0400 (EDT) Subject: [Cl-darcs-cvs] r127 - cl-darcs/trunk Message-ID: <20070824122539.30EE624004@common-lisp.net> Author: mhenoch Date: Fri Aug 24 08:25:38 2007 New Revision: 127 Modified: cl-darcs/trunk/touching.lisp Log: Add FIND-TOUCHING methods for FILE-PATCH, ADD-FILE-PATCH and RM-FILE-PATCH. Modified: cl-darcs/trunk/touching.lisp ============================================================================== --- cl-darcs/trunk/touching.lisp (original) +++ cl-darcs/trunk/touching.lisp Fri Aug 24 08:25:38 2007 @@ -56,10 +56,39 @@ (when touching-patches (make-instance 'composite-patch :patches (nreverse touching-patches))))) -(defmethod find-touching ((patch file-patch) filename direction) +(defmethod find-touching :around ((patch file-patch) filename direction) + ;; File patches touch a single file, so we can ignore them if they + ;; don't touch the file we're interested in. (declare (ignore direction)) (when (equal filename (patch-filename patch)) - (values patch filename))) + (call-next-method))) + +(defmethod find-touching ((patch file-patch) filename direction) + ;; By default, assume that file patches modify an existing file. + (declare (ignore direction)) + (values patch filename)) + +(defmethod find-touching ((patch add-file-patch) filename direction) + ;; Adding a file is different, though. + (ecase direction + (:forwards + ;; Should this happen in normal circumstances? If the file was + ;; created by this patch, noone would know about its existence + ;; before. + (values patch filename)) + (:backwards + ;; Before this patch, the file didn't exist. + (values patch nil)))) + +(defmethod find-touching ((patch rm-file-patch) filename direction) + ;; As is removing a file. + (ecase direction + (:forwards + ;; After this patch, the file doesn't exist. + (values patch nil)) + (:backwards + ;; Should this happen? + (values patch filename)))) (defmethod find-touching ((patch directory-patch) filename direction) (declare (ignore direction)) From mhenoch at common-lisp.net Fri Aug 24 12:30:54 2007 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Fri, 24 Aug 2007 08:30:54 -0400 (EDT) Subject: [Cl-darcs-cvs] r128 - cl-darcs/trunk Message-ID: <20070824123054.CC56F2608E@common-lisp.net> 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) From mhenoch at common-lisp.net Fri Aug 24 17:01:39 2007 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Fri, 24 Aug 2007 13:01:39 -0400 (EDT) Subject: [Cl-darcs-cvs] r129 - cl-darcs/trunk Message-ID: <20070824170139.83A562B129@common-lisp.net> 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 From mhenoch at common-lisp.net Fri Aug 24 17:20:35 2007 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Fri, 24 Aug 2007 13:20:35 -0400 (EDT) Subject: [Cl-darcs-cvs] r130 - cl-darcs/trunk Message-ID: <20070824172035.317392B12C@common-lisp.net> 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 From mhenoch at common-lisp.net Fri Aug 24 17:25:20 2007 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Fri, 24 Aug 2007 13:25:20 -0400 (EDT) Subject: [Cl-darcs-cvs] r131 - cl-darcs/trunk Message-ID: <20070824172520.B5C382B12C@common-lisp.net> 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 From mhenoch at common-lisp.net Fri Aug 24 17:26:50 2007 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Fri, 24 Aug 2007 13:26:50 -0400 (EDT) Subject: [Cl-darcs-cvs] r132 - cl-darcs/trunk Message-ID: <20070824172650.5C2ED2B12C@common-lisp.net> 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)) From mhenoch at common-lisp.net Fri Aug 24 17:31:20 2007 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Fri, 24 Aug 2007 13:31:20 -0400 (EDT) Subject: [Cl-darcs-cvs] r133 - cl-darcs/trunk Message-ID: <20070824173120.165832B12D@common-lisp.net> 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. From mhenoch at common-lisp.net Fri Aug 24 17:33:10 2007 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Fri, 24 Aug 2007 13:33:10 -0400 (EDT) Subject: [Cl-darcs-cvs] r134 - cl-darcs/trunk Message-ID: <20070824173310.A45ED2B137@common-lisp.net> 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