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

[Cl-darcs-cvs] r127 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Aug '07

24 Aug '07

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))

1 0

[Cl-darcs-cvs] r126 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Aug '07

24 Aug '07

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))))))

1 0

[Cl-darcs-cvs] r125 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Aug '07

24 Aug '07

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)))))

1 0

[Cl-darcs-cvs] r124 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Aug '07

24 Aug '07

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))))

1 0

[Cl-darcs-cvs] r123 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Aug '07

24 Aug '07

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

1 0

[Cl-darcs-cvs] r122 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Aug '07

24 Aug '07

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))))

1 0

[Cl-darcs-cvs] r121 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 Aug '07

24 Aug '07

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))))

1 0

[Cl-darcs-cvs] r120 - cl-darcs/trunk
by mhenoch＠common-lisp.net 22 Aug '07

22 Aug '07

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."

1 0

[Cl-darcs-cvs] r119 - cl-darcs/trunk
by mhenoch＠common-lisp.net 22 Aug '07

22 Aug '07

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))))

1 0

[Cl-darcs-cvs] r118 - cl-darcs/trunk
by mhenoch＠common-lisp.net 18 Apr '07

18 Apr '07

Author: mhenoch Date: Wed Apr 18 17:56:44 2007 New Revision: 118 Modified: cl-darcs/trunk/patchinfo.lisp Log: Use PRINT-UNREADABLE-OBJECT in PRINT-OBJECT of PATCHINFO. Modified: cl-darcs/trunk/patchinfo.lisp ============================================================================== --- cl-darcs/trunk/patchinfo.lisp (original) +++ cl-darcs/trunk/patchinfo.lisp Wed Apr 18 17:56:44 2007 @@ -118,8 +118,7 @@ copy)) (defmethod print-object ((patchinfo patchinfo) stream) - (if *print-readably* - (call-next-method) - (format stream "~A ~A (~A)" (patchinfo-date patchinfo) - (patchinfo-name patchinfo) - (patchinfo-author patchinfo)))) + (print-unreadable-object (patchinfo stream) + (format stream "~A ~A (~A)" (patchinfo-date patchinfo) + (patchinfo-name patchinfo) + (patchinfo-author patchinfo))))

1 0