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

[Cl-darcs-cvs] r7 - cl-darcs/trunk
by mhenoch＠common-lisp.net 10 Jun '06

10 Jun '06

Author: mhenoch Date: Sat Jun 10 18:28:47 2006 New Revision: 7 Added: cl-darcs/trunk/unwind.lisp Modified: cl-darcs/trunk/apply-patch.lisp cl-darcs/trunk/cl-darcs.asd cl-darcs/trunk/commute.lisp cl-darcs/trunk/invert-patch.lisp cl-darcs/trunk/patch-core.lisp cl-darcs/trunk/read-patch.lisp Log: Start hacking merger unwinding Modified: cl-darcs/trunk/apply-patch.lisp ============================================================================== --- cl-darcs/trunk/apply-patch.lisp (original) +++ cl-darcs/trunk/apply-patch.lisp Sat Jun 10 18:28:47 2006 @@ -319,4 +319,8 @@ (when (null undo) (error "Don't know how to undo ~A." patch)) - (apply-patch undo repodir))) + (apply-patch undo repodir) + + ;; After this comes "glump". As long as version is "0.0", it + ;; doesn't do anything. + (assert (string= (merger-version patch) "0.0")))) Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Sat Jun 10 18:28:47 2006 @@ -38,6 +38,8 @@ (:file "invert-patch" :depends-on ("patch-core")) (:file "touching" :depends-on ("patch-core")) (:file "commute" :depends-on ("patch-core")) + (:file "unwind" :depends-on ("patch-core")) + (:file "equal" :depends-on ("patch-core")) ;; Franz' inflate implementation #-allegro (:file "ifstar") Modified: cl-darcs/trunk/commute.lisp ============================================================================== --- cl-darcs/trunk/commute.lisp (original) +++ cl-darcs/trunk/commute.lisp Sat Jun 10 18:28:47 2006 @@ -1,12 +1,12 @@ (in-package :darcs) -(defgeneric commute-patches (p2 p1) +(defgeneric commute (p2 p1) (:documentation "Attempt to commute the patches P2 and P1. Return a list, (P1-NEW P2-NEW), such that applying P2-NEW and then P1-NEW has the same effect as applying P1 and then P2. If commutations fails, return nil.")) -(defmethod commute-patches :around ((p2 file-patch) (p1 file-patch)) +(defmethod commute :around ((p2 file-patch) (p1 file-patch)) "If P1 and P2 change different files, commutation is trivial." (let ((p1-file (patch-filename p1)) (p2-file (patch-filename p2))) @@ -14,7 +14,7 @@ (list p1 p2) (call-next-method)))) -(defmethod commute-patches ((p2 hunk-patch) (p1 hunk-patch)) +(defmethod commute ((p2 hunk-patch) (p1 hunk-patch)) "Attempt to commute the two hunk patches P1 and P2." (assert (equal (patch-filename p1) (patch-filename p2))) (with-accessors ((line1 hunk-line-number) Modified: cl-darcs/trunk/invert-patch.lisp ============================================================================== --- cl-darcs/trunk/invert-patch.lisp (original) +++ cl-darcs/trunk/invert-patch.lisp Sat Jun 10 18:28:47 2006 @@ -84,3 +84,11 @@ (defmethod invert-patch ((patch rm-dir-patch)) (make-instance 'add-dir-patch)) +(defmethod invert-patch ((patch merger-patch)) + (make-instance 'merger-patch + :version (merger-version patch) + :first (merger-first patch) + :second (merger-second patch) + :undo (merger-undo patch) + :unwindings (unwind patch) + :inverted (not (merger-inverted patch)))) Modified: cl-darcs/trunk/patch-core.lisp ============================================================================== --- cl-darcs/trunk/patch-core.lisp (original) +++ cl-darcs/trunk/patch-core.lisp Sat Jun 10 18:28:47 2006 @@ -33,7 +33,7 @@ ((patches :accessor patches :initarg :patches :initform ()))) (defclass file-patch (patch) - ((filename :accessor patch-filename :initarg :filename)) + ((filename :accessor patch-filename :initarg :filename :type pathname)) (:documentation "Base class for patches affecting a single file.")) (defmethod print-object ((patch file-patch) stream) @@ -75,9 +75,9 @@ (:documentation "A patch that changes a binary file.")) (defclass token-replace-patch (file-patch) - ((regexp :accessor token-regexp :initarg :regexp) - (old-token :accessor old-token :initarg :old-token) - (new-token :accessor new-token :initarg :new-token)) + ((regexp :accessor token-regexp :initarg :regexp :type 'string) + (old-token :accessor old-token :initarg :old-token :type 'string) + (new-token :accessor new-token :initarg :new-token :type 'string)) (:documentation "A patch that replaces one token with another.")) (defmethod print-object ((patch token-replace-patch) stream) @@ -161,8 +161,9 @@ (defmethod print-object ((patch merger-patch) stream) (if *print-readably* (call-next-method) - (format stream "#<~A ~A: ~A ~A>" + (format stream "#<~A ~:[(inverted) ~;~]~A: ~A ~A>" (type-of patch) + (merger-inverted patch) (merger-version patch) (merger-first patch) (merger-second patch)))) Modified: cl-darcs/trunk/read-patch.lisp ============================================================================== --- cl-darcs/trunk/read-patch.lisp (original) +++ cl-darcs/trunk/read-patch.lisp Sat Jun 10 18:28:47 2006 @@ -250,25 +250,26 @@ (let ((p1 (read-patch stream)) (p2 (read-patch stream))) (read-token stream) ; #\) - (let* ((is-merger1 (typep p1 'merger-patch)) - (is-merger2 (typep p2 'merger-patch)) - (undo - (cond - ((and is-merger1 is-merger2) - ;; TBD - nil - ) - ((and (not is-merger1) (not is-merger2)) - (invert-patch p1)) - ((and is-merger1 (not is-merger2)) - (make-instance 'composite-patch)) ;empty patch - ((and (not is-merger1) is-merger2) - (make-instance 'composite-patch - :patches (list (invert-patch p1) - (merger-undo p2))))))) - (make-instance 'merger-patch - :version version :first p1 :second p2 - :inverted inverted :undo undo))))) + (let ((merger (make-instance 'merger-patch + :version version :first p1 :second p2 + :inverted inverted))) + (let* ((is-merger1 (typep p1 'merger-patch)) + (is-merger2 (typep p2 'merger-patch))) + (setf (merger-undo merger) + (cond + ((and is-merger1 is-merger2) + (make-instance 'composite-patch + :patches (mapcar #'invert-patch + (cdr (unwind merger))))) + ((and (not is-merger1) (not is-merger2)) + (invert-patch p1)) + ((and is-merger1 (not is-merger2)) + (make-instance 'composite-patch)) ;empty patch + ((and (not is-merger1) is-merger2) + (make-instance 'composite-patch + :patches (list (invert-patch p1) + (merger-undo p2))))))) + merger)))) (defun read-token-replace (stream) "Read a token replacing patch." Added: cl-darcs/trunk/unwind.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/unwind.lisp Sat Jun 10 18:28:47 2006 @@ -0,0 +1,112 @@ +(in-package :darcs) + +;; From PatchCommute.lhs + +(defmethod patch-unwindings ((patch merger-patch)) + (if (slot-boundp patch 'unwindings) + (merger-unwindings patch) + (unwind patch))) + +(defmethod patch-unwindings ((patch patch)) + (list patch)) + +(defun unwind (patch) + (let* ((p1 (merger-first patch)) + (p2 (merger-second patch)) + (p1-unwindings (patch-unwindings p1)) + (p2-unwindings (patch-unwindings p2))) + (assert (consp p1-unwindings)) + (assert (consp p2-unwindings)) + (setf (merger-unwindings patch) + (cons patch + (cons p1 + (reconcile-unwindings patch + (cdr p1-unwindings) + (cdr p2-unwindings))))))) + +(defun reconcile-unwindings (p p1s p2s) + (cond + ((null p1s) + p2s) + ((null p2s) + p1s) + (t + + ;; First, try to find permutations of the two lists p1s and p2s + ;; where the two head elements are equal. If we found one such + ;; permutation, put the head element at the head of the + ;; unwinding, and recursively process the tails. + ;; "-p" stands for "permutation" here. + (let ((equal-heads + (dolist (p1s-p (all-head-permutations p1s)) + (dolist (p2s-p (all-head-permutations p2s)) + (when (equal-patch + (car p1s-p) + (car p2s-p)) + (return (list p1s-p p2s-p))))))) + (cond + (equal-heads + (destructuring-bind (p1s-p p2s-p) equal-heads + (cons (car p1s-p) + (reconcile-unwindings p (cdr p1s-p) + (cdr p2s-p))))) + + (t + + ;; If we can't find any such permutation, take the first patch + ;; from either list, invert it, commute it through the other + ;; list, put the non-inverted patch at the head of the unwinding, + ;; and recursively process the tail of the one list and the + ;; commuted-through list. + (let ((p2s-c (nreverse (put-before (car p1s) (reverse p2s))))) + (if p2s-c + (cons (car p1s) (reconcile-unwindings p (cdr p1s) p2s-c)) + (let ((p1s-c (nreverse (put-before (car p2s) (reverse p1s))))) + (when p1s-c + (cons (car p2s) (reconcile-unwindings p p1s-c (cdr p2s))))))))))))) + +(defun put-before (p1 patches) + "Transform PATCHES such that P1 were applied before them. +Return nil if impossible. + +P1 is a patch whose context consists of PATCHES. It is inverted, +and commuted through PATCHES, to finally give a list of patches +whose context consists of P1. If any commutation fails, this +operation fails as well." + (destructuring-bind (&optional p2-c p1-c) (commute (invert-patch p1) (car patches)) + (and p2-c p1-c + (commute p1 p2-c) + (let ((rest (put-before p1-c (cdr patches)))) + (and rest (cons p2-c rest)))))) + +(defun all-head-permutations (ps) + "Return all possible permutations of PS. +PS is a list of patches in reverse order." + (reverse + (mapcar #'reverse + (remove-duplicates + (tail-permutations-normal-order ps) + :test (lambda (a b) + (equal-list #'equal-patch a b)))))) + +(defun tail-permutations-normal-order (ps) + (if (null ps) + ps + (let ((swapped-ps (swap-to-back-normal-order ps)) + (rest (mapcar + (lambda (p) (cons (car ps) p)) + (tail-permutations-normal-order (cdr ps))))) + (if swapped-ps ;separate () and :fail? + (cons swapped-ps rest) + rest)))) + +(defun swap-to-back-normal-order (ps) + ;; If there are zero or one element, just return. + (if (or (null (cdr ps)) (null (cddr ps))) + ps + (let ((commuted (commute (second ps) (first ps)))) + (when commuted ;XXX: separate failure? + (let ((rest (swap-to-back-normal-order + (cons (first commuted) (cddr ps))))) + (when rest + (cons (second commuted) rest)))))))

1 0

[Cl-darcs-cvs] r6 - cl-darcs/trunk
by mhenoch＠common-lisp.net 10 Jun '06

10 Jun '06

Author: mhenoch Date: Sat Jun 10 11:50:26 2006 New Revision: 6 Added: cl-darcs/trunk/commute.lisp Modified: cl-darcs/trunk/cl-darcs.asd Log: Start hacking commutation. Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Sat Jun 10 11:50:26 2006 @@ -37,6 +37,7 @@ (:file "apply-patch" :depends-on ("patch-core")) (:file "invert-patch" :depends-on ("patch-core")) (:file "touching" :depends-on ("patch-core")) + (:file "commute" :depends-on ("patch-core")) ;; Franz' inflate implementation #-allegro (:file "ifstar") Added: cl-darcs/trunk/commute.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/commute.lisp Sat Jun 10 11:50:26 2006 @@ -0,0 +1,58 @@ +(in-package :darcs) + +(defgeneric commute-patches (p2 p1) + (:documentation "Attempt to commute the patches P2 and P1. +Return a list, (P1-NEW P2-NEW), such that applying P2-NEW and then +P1-NEW has the same effect as applying P1 and then P2. +If commutations fails, return nil.")) + +(defmethod commute-patches :around ((p2 file-patch) (p1 file-patch)) + "If P1 and P2 change different files, commutation is trivial." + (let ((p1-file (patch-filename p1)) + (p2-file (patch-filename p2))) + (if (not (equal p1-file p2-file)) + (list p1 p2) + (call-next-method)))) + +(defmethod commute-patches ((p2 hunk-patch) (p1 hunk-patch)) + "Attempt to commute the two hunk patches P1 and P2." + (assert (equal (patch-filename p1) (patch-filename p2))) + (with-accessors ((line1 hunk-line-number) + (old1 hunk-old-lines) + (new1 hunk-new-lines)) p1 + (with-accessors ((line2 hunk-line-number) + (old2 hunk-old-lines) + (new2 hunk-new-lines)) p2 + (cond + ((< (+ line1 (length new1)) line2) + ;; The first patch changes text before the second patch. + (list p1 + (make-instance 'hunk-patch :filename (patch-filename p2) + :line-number (+ line2 (- (length new1)) (length old1)) + :old old2 :new new2))) + ((< (+ line2 (length old2) line1)) + ;; The second patch changes text before the first patch. + (list (make-instance 'hunk-patch :filename (patch-filename p1) + :line-number (+ line1 (length new2) (- (length old2))) + :old old1 :new new1) + p2)) + ((and (= (+ line1 (length new1)) line2) + (notany #'zerop + (mapcar #'length (list old1 old2 new1 new2)))) + ;; The first patch goes exactly until the beginning of the second patch. + (list p1 + (make-instance 'hunk-patch :filename (patch-filename p2) + :line-number (+ line2 (- (length new1)) (length old1)) + :old old2 :new new2))) + ((and (= (+ line2 (length old2)) line1) + (notany #'zerop + (mapcar #'length (list old1 old2 new1 new2)))) + ;; The second patch goes exactly until the beginning of the first patch. + (list (make-instance 'hunk-patch :filename (patch-filename p1) + :line-number (+ line1 (length new2) (- (length old2))) + :old old1 :new new1) + p2)) + (t + ;; In other cases, there is no failsafe way to commute the + ;; patches, so we give up. + nil)))))

1 0

[Cl-darcs-cvs] r5 - cl-darcs/trunk
by mhenoch＠common-lisp.net 24 May '06

24 May '06

Author: mhenoch Date: Wed May 24 17:00:06 2006 New Revision: 5 Modified: cl-darcs/trunk/apply-patch.lisp Log: Remove superfluous format argument. Modified: cl-darcs/trunk/apply-patch.lisp ============================================================================== --- cl-darcs/trunk/apply-patch.lisp (original) +++ cl-darcs/trunk/apply-patch.lisp Wed May 24 17:00:06 2006 @@ -210,7 +210,7 @@ (defun apply-patch-list (patches repodir) "Apply a list of patches, attempting to optimize for adjacent hunks." - (dformat "~&Looking for adjacent hunks..." patches) + (dformat "~&Looking for adjacent hunks...") (loop while patches do (etypecase (car patches)

1 0

[Cl-darcs-cvs] r4 - cl-darcs/trunk
by mhenoch＠common-lisp.net 23 May '06

23 May '06

Author: mhenoch Date: Tue May 23 13:12:51 2006 New Revision: 4 Modified: cl-darcs/trunk/unreadable-stream.lisp Log: Handle unreading of empty sequences. Modified: cl-darcs/trunk/unreadable-stream.lisp ============================================================================== --- cl-darcs/trunk/unreadable-stream.lisp (original) +++ cl-darcs/trunk/unreadable-stream.lisp Tue May 23 13:12:51 2006 @@ -112,7 +112,7 @@ (sequence (third buffer-entry))) (pop buffer) ;; Simple case: it's a vector, and we haven't begun nibbling at it. - (if (and (vectorp sequence) (= (first buffer-entry) 0)) + (if (and (vectorp sequence) (= start 0)) sequence ;; Otherwise, make a new vector. (make-array (- end start) :element-type '(unsigned-byte 8) @@ -133,13 +133,18 @@ "Store SEQUENCE at the head of the unread buffer. It is assumed that SEQUENCE will not be modified." (with-slots (buffer) stream - (push (list 0 (length sequence) sequence) buffer))) + ;; Empty sequences must not be stored in the buffer. + (unless (zerop (length sequence)) + (push (list 0 (length sequence) sequence) buffer)))) (defmethod unread-line ((stream unreadable-stream) line) "Store LINE with an appended newline at the head of the unread buffer. It is assumed that SEQUENCE will not be modified." (with-slots (buffer) stream - (push (list 0 (length line) line :line) buffer))) + ;; If the line is empty, just store a newline. + (if (zerop (length line)) + (push 10 buffer) + (push (list 0 (length line) line :line) buffer)))) (defmethod print-object ((object unreadable-stream) stream) (if *print-readably* (call-next-method)

1 0

[Cl-darcs-cvs] r3 - cl-darcs/trunk
by mhenoch＠common-lisp.net 23 May '06

23 May '06

Author: mhenoch Date: Tue May 23 13:12:09 2006 New Revision: 3 Modified: cl-darcs/trunk/apply-patch.lisp Log: Handle the case of subsequent hunks changing the same line. Modified: cl-darcs/trunk/apply-patch.lisp ============================================================================== --- cl-darcs/trunk/apply-patch.lisp (original) +++ cl-darcs/trunk/apply-patch.lisp Tue May 23 13:12:09 2006 @@ -27,10 +27,13 @@ (,filename-gensym ,filename)) (restart-case ;; Open the file to patch for reading. - (with-open-file (,instreamvar ,filename-gensym - :direction :input - :if-does-not-exist :error - :element-type '(unsigned-byte 8)) + (with-open-stream (,instreamvar + (make-instance 'unreadable-stream + :base-stream + (open ,filename-gensym + :direction :input + :if-does-not-exist :error + :element-type '(unsigned-byte 8)))) ;; Open a temporary file for writing. (with-temp-file (,outstreamvar :element-type '(unsigned-byte 8)) (progn ,@body) @@ -40,7 +43,7 @@ (setf ,files-copied-gensym t) ;; Copy the temporary file over the original. - (fad:copy-file (pathname ,outstreamvar) (pathname ,instreamvar) :overwrite t))) + (fad:copy-file (pathname ,outstreamvar) ,filename :overwrite t))) ;; Until the temporary file is copied over the original, we can ;; retry as many times we want. @@ -292,12 +295,14 @@ ;; them to the temporary file. )))) - ;; Now, let's add lines, increasing the line counter as we - ;; go. - (dolist (new (hunk-new-lines hunk)) - (maybe-terpri) - (write-sequence new out) - (incf line-number))) + ;; Now, let's add lines. The obvious way to do it would + ;; be to print the lines to output, increasing the line + ;; counter for every line. However, in some circumstances + ;; there are two subsequent hunks modifying the same line + ;; (i.e. s/A/B/ and s/B/C/ are expected to have the same + ;; result as s/A/C/), so we unread the lines instead. + (dolist (new (reverse (hunk-new-lines hunk))) + (unread-line in new))) ;; And output the lines after all hunks (loop for line = (read-binary-line in nil :eof)

1 0

[Cl-darcs-cvs] r2 - cl-darcs/trunk
by mhenoch＠common-lisp.net 23 May '06

23 May '06

Author: mhenoch Date: Tue May 23 10:15:12 2006 New Revision: 2 Modified: cl-darcs/trunk/apply-patch.lisp Log: Remove superfluous debug output. Modified: cl-darcs/trunk/apply-patch.lisp ============================================================================== --- cl-darcs/trunk/apply-patch.lisp (original) +++ cl-darcs/trunk/apply-patch.lisp Tue May 23 10:15:12 2006 @@ -217,16 +217,14 @@ (equal (patch-filename (car patches)) filename)) collect (car patches) into hunks do (setf patches (cdr patches)) - finally (progn - (dformat "~&Found hunks: ~A" hunks) - (loop + finally (loop (restart-case (progn (apply-hunk-list hunks repodir) (return)) (retry-hunks () :report (lambda (stream) - (format stream "Retry patch ~A to ~A" hunks filename))))))))) + (format stream "Retry patch ~A to ~A" hunks filename)))))))) (patch (apply-patch (car patches) repodir) (setf patches (cdr patches))))))

1 0

[Cl-darcs-cvs] r1 - in cl-darcs: . branches tags trunk
by mhenoch＠common-lisp.net 23 May '06

23 May '06

Author: mhenoch Date: Tue May 23 08:45:51 2006 New Revision: 1 Added: cl-darcs/ cl-darcs/branches/ cl-darcs/tags/ cl-darcs/trunk/ cl-darcs/trunk/COPYING cl-darcs/trunk/README cl-darcs/trunk/apply-patch.lisp cl-darcs/trunk/binary-text.lisp cl-darcs/trunk/cl-darcs.asd cl-darcs/trunk/get.lisp cl-darcs/trunk/ifstar.lisp cl-darcs/trunk/inflate.lisp cl-darcs/trunk/init.lisp cl-darcs/trunk/invert-patch.lisp cl-darcs/trunk/packages.lisp cl-darcs/trunk/patch-core.lisp cl-darcs/trunk/patchinfo.lisp cl-darcs/trunk/prefs.lisp cl-darcs/trunk/read-patch.lisp cl-darcs/trunk/touching.lisp cl-darcs/trunk/unreadable-stream.lisp cl-darcs/trunk/upath.lisp cl-darcs/trunk/util.lisp Log: Initial import Added: cl-darcs/trunk/COPYING ============================================================================== --- (empty file) +++ cl-darcs/trunk/COPYING Tue May 23 08:45:51 2006 @@ -0,0 +1,340 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + <one line to give the program's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + + 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 + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + <signature of Ty Coon>, 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. Added: cl-darcs/trunk/README ============================================================================== --- (empty file) +++ cl-darcs/trunk/README Tue May 23 08:45:51 2006 @@ -0,0 +1,44 @@ +This is cl-darcs, a darcs client written in Common Lisp. I started +writing it because the original client requires GHC (the Glasgow +Haskell Compiler), which is not available on all platforms. + +cl-darcs is currently in a very early state of development. + +* Usage + +At the REPL: + +(asdf:oos 'asdf:load-op :cl-darcs) +(in-package :cl-darcs) +(get-repo "http://path/to/repo" "/local/non-existent/directory/") + +Or if you want to select which patches to apply: + +(get-repo "http://path/to/repo" "/local/repo-dir/" :query t) +(apply-some-patches "/local/repo-dir/") + +That's all that is implemented so far. + +* Compatibility + +I primarily develop cl-darcs on CLISP, but try to keep it working on +SBCL as well. Users of non-Unix systems probably need to change +MAKE-TEMP-FILE-NAME in util.lisp. + +* License + +cl-darcs is covered by the GPL, like the original darcs client. +ifstar.lisp and inflate.lisp were borrowed from Franz Inc, and are +public domain and LLGPL, respectively. + +* Links + +Project page: http://common-lisp.net/project/cl-darcs/ +(the place to look for mailing lists) + +The original darcs: http://www.darcs.net/ + + +Local variables: +mode: outline +End: Added: cl-darcs/trunk/apply-patch.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/apply-patch.lisp Tue May 23 08:45:51 2006 @@ -0,0 +1,319 @@ +;;; 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) + +(defmacro with-file-patching ((instreamvar outstreamvar filename) &body body) + "Open FILENAME for patching. +Bind INSTREAMVAR to a stream that reads from FILENAME. +Bind OUTSTREAMVAR to a stream that writes to a temporary file. +If BODY finishes normally, overwrite FILENAME with the temporary file." + (let ((files-copied-gensym (gensym)) + (filename-gensym (gensym))) + `(let ((,files-copied-gensym nil) + (,filename-gensym ,filename)) + (restart-case + ;; Open the file to patch for reading. + (with-open-file (,instreamvar ,filename-gensym + :direction :input + :if-does-not-exist :error + :element-type '(unsigned-byte 8)) + ;; Open a temporary file for writing. + (with-temp-file (,outstreamvar :element-type '(unsigned-byte 8)) + (progn ,@body) + + (close ,instreamvar) + (close ,outstreamvar) + + (setf ,files-copied-gensym t) + ;; Copy the temporary file over the original. + (fad:copy-file (pathname ,outstreamvar) (pathname ,instreamvar) :overwrite t))) + + ;; Until the temporary file is copied over the original, we can + ;; retry as many times we want. + ;; XXX: how can we enter a new version of the function? + ;; (retry-patch () +;; :test (lambda (c) (declare (ignore c)) (not ,files-copied-gensym)) +;; :report (lambda (stream) +;; (format stream "Revert changes to ~A and retry patch" ,filename-gensym)) +;; ,retry-form) + + (ignore-patch () + :report (lambda (stream) + (format stream "Ignore patch to ~A" ,filename-gensym)) + nil))))) + +(defgeneric apply-patch (patch repodir) + (:documentation "Apply PATCH to working copy in REPODIR.")) + +(defmethod apply-patch :around (patch repodir) + "Offer a RETRY restart for all patches. +In some cases, the patch might be applied twice." + (restart-case + (call-next-method) + (retry () + :report (lambda (stream) + (format stream "Retry patch ~A (possibly non-idempotent)" patch)) + (apply-patch patch repodir)) + (ignore () + :report (lambda (stream) + (format stream "Ignore patch ~A" patch)) + nil))) + +(defmethod apply-patch ((patch named-patch) repodir) + "Apply PATCH in REPODIR. +That is, simply apply the patch contained in the named patch." + (dformat "~&Applying ~A: \"~A\"." + (patchinfo-date (named-patch-patchinfo patch)) + (patchinfo-name (named-patch-patchinfo patch))) + (apply-patch (named-patch-patch patch) repodir)) + +(defmethod apply-patch ((patch composite-patch) repodir) + (apply-patch-list (patches patch) repodir)) + +(defmethod apply-patch ((patch change-pref-patch) repodir) + (with-accessors ((pref change-pref-which) + (from change-pref-from) + (to change-pref-to)) patch + (let ((old-value (or (get-pref repodir pref) ""))) + (unless (string= from old-value) + (warn + "While changing pref ~S to ~S, expected old value to be ~S, but it was ~S." + pref to from old-value)) + (set-pref repodir pref to)))) + +(defmethod apply-patch ((patch add-file-patch) repodir) + "Create a file in REPODIR, by PATCH." + (let ((new-file (merge-pathnames + (patch-filename patch) repodir))) + (dformat "~&Creating file ~A." new-file) + (open new-file :direction :probe + :if-does-not-exist :create + :if-exists :error))) + +(defmethod apply-patch ((patch binary-patch) repodir) + "Apply a binary patch in REPODIR." + (let ((file (merge-pathnames (patch-filename patch) repodir))) + ;; Check that the file matches the old content. + (with-open-file (in file + :direction :input :if-does-not-exist :error + :element-type '(unsigned-byte 8)) + (when (or (/= (file-length in) (length (binary-oldhex patch))) + (let ((bytes (make-array (file-length in) + :element-type '(unsigned-byte 8)))) + (read-sequence bytes in) + (not (equalp bytes (binary-oldhex patch))))) + (error "Contents of ~A don't match patch." file))) + ;; Overwrite with new content. + (with-open-file (out file + :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (write-sequence (binary-newhex patch) out)))) + +(defmethod apply-patch ((patch rm-file-patch) repodir) + "Delete a file in REPODIR. File should be empty. +If it's not, a warning will be signalled." + (let ((the-file (merge-pathnames + (patch-filename patch) repodir))) + (with-open-file (in the-file :direction :input + :if-does-not-exist :error) + (let ((length (file-length in))) + (unless (zerop length) + (warn "File ~A is not empty (contains ~A bytes)." the-file length)))) + (dformat "~&Deleting file ~A." the-file) + (delete-file the-file))) + +(defmethod apply-patch ((patch add-dir-patch) repodir) + "Create a directory in REPODIR." + (let ((new-dir (merge-pathnames (patch-directory patch) repodir))) + (dformat "~&Creating directory ~A." new-dir) + (make-dir new-dir))) + +(defmethod apply-patch ((patch rm-dir-patch) repodir) + "Delete a directory in REPODIR. Directory must be empty." + (let ((dir-to-remove (merge-pathnames (patch-directory patch) repodir))) + (dformat "~&Deleting directory ~A." dir-to-remove) + (delete-dir dir-to-remove))) + +(defmethod apply-patch ((patch move-patch) repodir) + "Move a file in REPODIR." + (let ((from (merge-pathnames (patch-move-from patch) repodir)) + (to (merge-pathnames (patch-move-to patch) repodir))) +;; (fad:copy-file from to :overwrite nil) +;; (delete-file from) + + ;; This seems to be an easier method, which works even if we're + ;; moving a directory. + #+sbcl (sb-ext:run-program "mv" (list (namestring from) (namestring to)) + :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))))) + +(defmethod apply-patch ((patch token-replace-patch) repodir) + "Apply a token replace patch to a file in REPODIR." + (let ((filename (merge-pathnames (patch-filename patch) repodir)) + (old-regexp (cl-ppcre:create-scanner + (format nil "(^|[^~A])~A($|[^~A])" + (token-regexp patch) + (old-token patch) + (token-regexp patch)))) + (new-regexp (cl-ppcre:create-scanner + (format nil "(^|[^~A])~A($|[^~A])" + (token-regexp patch) + (new-token patch) + (token-regexp patch)))) + (replacement (format nil "\\1~A\\2" (new-token patch)))) + (dformat "~&Patching ~A with ~A." filename patch) + (with-file-patching (in out filename) (apply-patch patch repodir) + (let ((file-empty t)) + (flet ((maybe-terpri () + ;; Unless we're writing the first line, we have to + ;; terminate the previous one. + (if file-empty + (setf file-empty nil) + (terpri out)))) + (loop + (multiple-value-bind (line delim) (read-until #\Newline in nil :eof) + (setf line (coerce line 'string)) + (when (cl-ppcre:scan new-regexp line) + (cerror "Ignore" "While replacing ~S with ~S, found ~S before patching: ~S." + (old-token patch) (new-token patch) (new-token patch) line)) + + (maybe-terpri) + (when (eql delim :eof) + (return)) + + (let ((patched-line (cl-ppcre:regex-replace-all old-regexp line replacement))) + (write-string patched-line out))))))))) + +(defmethod apply-patch ((patch hunk-patch) repodir) + "Apply a single hunk patch to REPODIR." + ;; This is just a special case of having several hunks in a row. + (apply-hunk-list (list patch) repodir)) + +(defun apply-patch-list (patches repodir) + "Apply a list of patches, attempting to optimize for adjacent hunks." + (dformat "~&Looking for adjacent hunks..." patches) + (loop while patches + do + (etypecase (car patches) + (hunk-patch + (let ((filename (patch-filename (car patches)))) + (loop while (and (typep (car patches) 'hunk-patch) + (equal (patch-filename (car patches)) filename)) + collect (car patches) into hunks + do (setf patches (cdr patches)) + finally (progn + (dformat "~&Found hunks: ~A" hunks) + (loop + (restart-case + (progn + (apply-hunk-list hunks repodir) + (return)) + (retry-hunks () + :report (lambda (stream) + (format stream "Retry patch ~A to ~A" hunks filename))))))))) + (patch + (apply-patch (car patches) repodir) + (setf patches (cdr patches)))))) + +(defun apply-hunk-list (hunks repodir) + "Apply HUNKS to REPODIR. +HUNKS is assumed to be a list of HUNK-PATCHes, each acting on the +same file." + ;; Darcs' idea of a line is a string of characters + ;; terminated by a newline or end-of-file. Thus, if a + ;; file ends with a newline, it has a last line with + ;; zero characters. + (let* ((filename (merge-pathnames + (patch-filename (car hunks)) + repodir))) + (dformat "~&Patching ~A with ~A." filename hunks) + (with-file-patching (in out filename) + (let ((line-number 1) (file-empty t)) + (flet ((maybe-terpri () + ;; Unless we're writing the first line, we have to + ;; terminate the previous one. + (if file-empty + (setf file-empty nil) + (write-byte 10 out)))) + (dolist (hunk hunks) + ;; Lines not touched by the hunks are just output. + (loop while (< line-number (hunk-line-number hunk)) + do (let ((line (read-binary-line in nil :eof))) + ;; See if we are skipping more than we have. + (when (and (eql line :eof) + (/= line-number (1- (hunk-line-number hunk)))) + (error "Hunk starts at line ~A, but file is shorter." + (hunk-line-number hunk))) + + (maybe-terpri) + (unless (eql line :eof) + (write-sequence line out)) + + (incf line-number))) + + ;; Start by removing lines... + (loop for old on (hunk-old-lines hunk) + do + (let ((line (read-binary-line in nil :eof))) + (cond + ((and (eql line :eof) + (= (length old) 1) + (= (length (car old)) 0)) + ;; Sometimes, the file is empty, but the patch + ;; wants to remove one empty line. That's an + ;; effect of different views of what a line is, + ;; so let it pass. + ) + ((eql line :eof) + (error "Hunk ~A too long (looking for ~S)." + hunk (bytes-to-string (car old)))) + ;; Note that equalp would do case-insensitive + ;; comparison if these were not byte arrays. + ((not (equalp (car old) line)) + (error "Hunk ~A: text ~S doesn't match file text ~S." + hunk (bytes-to-string (car old)) + (bytes-to-string line))) + (t + ;; ...which in this context means not writing + ;; them to the temporary file. + )))) + + ;; Now, let's add lines, increasing the line counter as we + ;; go. + (dolist (new (hunk-new-lines hunk)) + (maybe-terpri) + (write-sequence new out) + (incf line-number))) + + ;; And output the lines after all hunks + (loop for line = (read-binary-line in nil :eof) + until (eql line :eof) + do (maybe-terpri) + (write-sequence line out))))))) + +(defmethod apply-patch ((patch merger-patch) repodir) + "Apply a merger patch to REPODIR." + (dformat "~&Applying merger patch ~A" patch) + ;; I'll gladly admit to not understanding what this is supposed to + ;; do. This is a simplified version of merger_equivalent. + (let ((undo (merger-undo patch))) + (when (null undo) + (error "Don't know how to undo ~A." patch)) + + (apply-patch undo repodir))) Added: cl-darcs/trunk/binary-text.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/binary-text.lisp Tue May 23 08:45:51 2006 @@ -0,0 +1,49 @@ +;;; 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) + +;; This is a wrapper stream that reads from a binary stream and +;; returns the data as characters with as little change as possible. +;; Specifically, only 10 is treated as newline, and byte values are +;; not translated between any charsets. + +(defclass binary-text-input + (trivial-gray-streams:fundamental-character-input-stream) + ((stream :initarg :base-stream) + (unread :initform nil))) + +(defmethod trivial-gray-streams:stream-read-char ((stream + binary-text-input)) + (or (pop (slot-value stream 'unread)) + (let ((byte (read-byte (slot-value stream 'stream) nil :eof))) + (case byte + (:eof + :eof) + (10 + #\Newline) + (t + (code-char byte)))))) + +(defmethod trivial-gray-streams:stream-unread-char ((stream + binary-text-input) + char) + (push char (slot-value stream 'unread))) + +(defmethod close ((stream binary-text-input) &key abort) + "Close the wrapped stream." + (close (slot-value stream 'stream) :abort abort) + (call-next-method)) Added: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- (empty file) +++ cl-darcs/trunk/cl-darcs.asd Tue May 23 08:45:51 2006 @@ -0,0 +1,43 @@ +;;; -*- mode: lisp; -*- + +(defpackage cl-darcs-system + (:use :cl :asdf)) + +(in-package :cl-darcs-system) + +(defsystem cl-darcs + :description "Darcs client" + :version "0.0.1" + :licence "GPL" + :author "Magnus Henoch <henoch(a)dtek.chalmers.se>" + :depends-on (:split-sequence + ;; HTTP client + :aserve + :trivial-gray-streams + ;; SHA1, hex etc + :ironclad + ;; Ironclad's SHA1 doesn't work with CLISP yet + #+clisp :sb-sha1 + ;; Files and directories + :cl-fad) + + :components + ((:file "packages") + (:file "util" :depends-on ("packages" #-allegro "inflate")) + (:file "unreadable-stream" :depends-on ("packages")) + (:file "upath" :depends-on ("util" #|"binary-text"|#)) + + (:file "patchinfo" :depends-on ("util")) + (:file "get" :depends-on ("util")) + (:file "init" :depends-on ("util")) + (:file "prefs" :depends-on ("util")) + + (:file "patch-core" :depends-on ("util")) + (:file "read-patch" :depends-on ("patch-core")) + (:file "apply-patch" :depends-on ("patch-core")) + (:file "invert-patch" :depends-on ("patch-core")) + (:file "touching" :depends-on ("patch-core")) + + ;; Franz' inflate implementation + #-allegro (:file "ifstar") + #-allegro (:file "inflate" :depends-on ("ifstar")))) Added: cl-darcs/trunk/get.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/get.lisp Tue May 23 08:45:51 2006 @@ -0,0 +1,183 @@ +;;; 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) + +;; get_cmd in Get.lhs +(defun get-repo (inrepodir outname &key (partial nil) (query nil)) + (setf outname (fad:pathname-as-directory outname)) + ;; other access methods later... + ;; XXX: checkpoints? + (let* ((repodir (make-upath inrepodir)) + (patchinfo-list (read-repo-patch-list repodir)) + ;; We should probably download checkpoint patches, btw... + (checkpoint (when partial + (car (last (read-checkpoint-list repodir)))))) + ;; Create directories... + (prepare-new-repo outname) + + (when checkpoint + (format t "~&Copying checkpoint...") + (copy-checkpoint repodir outname checkpoint) + ;; After copying, we can read the checkpoint from OUTNAME. + (let ((checkpoint-patch (read-checkpoint-from-repo outname checkpoint))) + (apply-patch checkpoint-patch outname)) + (format t "done")) + + (let ((patches (if checkpoint + (find-remaining-patches patchinfo-list checkpoint) + patchinfo-list))) + (copy-repo-patches repodir outname patches) + + (if (or (null query) (y-or-n-p "Apply patches?")) + (progn + (format t "~&Applying patches") + (dolist (patch patches) + (apply-patch (read-patch-from-repo outname patch) + outname) + (format t "."))) + (format t "~&Not applying patches")) + (format t "~&All done")))) + +(defun apply-some-patches (repo) + "Interactively select some patches to apply to REPO." + (setf repo (fad:pathname-as-directory repo)) + (let ((patch-files + (sort + (directory + (merge-pathnames + (make-pathname :directory (list :relative "_darcs" "patches") + :name :wild :type "gz") + repo)) + #'string< :key #'pathname-name))) + (format t "~&Available patches:") + (loop for file in patch-files + count file into i + do (format t "~&~3@A ~A" i (pathname-name file))) + (format t "~&Specify inclusive start and end (NIL will do): ") + (let ((start (read)) (end (read))) + (if start + (decf start) + (setf start 0)) + (let ((file-subset (subseq patch-files start end))) + (format t "~&Applying patches") + (dolist (patch-file file-subset) + (apply-patch (read-patch-from-file patch-file) repo) + (format t ".")) + (format t "~&Done"))))) + +(defun prepare-new-repo (outname) + "Create directories for starting a repo at OUTNAME." + (make-dir outname) + (make-dir (merge-pathnames (make-pathname :directory (list :relative "_darcs")) + outname)) + (dolist (dir '("patches" "checkpoints" "prefs")) + (make-dir (merge-pathnames + (make-pathname :directory (list :relative "_darcs" dir)) + outname)))) + +;; {lazily,}read_repo in DarcsRepo.lhs +;; read_repo_private in DarcsRepo.lhs +(defun read-repo-patch-list (inrepodir &optional inventory-file) + "Read patch info for INREPODIR from INVENTORY-FILE. +Return a list of patchinfo structures." + (when (null inventory-file) + (setf inventory-file (upath-subdir inrepodir '("_darcs") "inventory"))) + (let (tag-patches patches) + (with-open-stream (in (make-instance 'unreadable-stream + :base-stream (open-upath inventory-file :binary t))) + ;; If first line is "Starting with tag:", + (let ((first-line (read-binary-line in))) + (if (string= (bytes-to-string first-line) "Starting with tag:") + (let* ((tag-patch + ;; read the first patch... + (read-patchinfo in)) + (new-filename (patchinfo-make-filename tag-patch))) + ;; ...for the first patch is a tag. Recursively read the + ;; inventory of that file. + (setf tag-patches + (read-repo-patch-list + inrepodir (upath-subdir inrepodir '("_darcs" "inventories") new-filename))) + (setf patches (list tag-patch))) + ;; If it's not, pretend we never read that line. + (unread-line in first-line))) + ;; Then, just read all patches in the file. + (format t "~&Reading patchinfo from ~A" inventory-file) + (setf patches + (loop for patch = (read-patchinfo in) + while patch collect patch + do (princ #\.)))) + (nconc tag-patches patches))) + +(defun read-patch-from-repo (repodir patchinfo) + "Read patch named by PATCHINFO from REPODIR." + (read-patch-from-file + (upath-subdir repodir '("_darcs" "patches") (patchinfo-make-filename patchinfo)))) + +(defun read-checkpoint-from-repo (repodir patchinfo) + "Read checkpoint named by PATCHINFO from REPODIR." + (read-patch-from-file + (upath-subdir repodir '("_darcs" "checkpoints") (patchinfo-make-filename patchinfo)))) + +(defun read-checkpoint-list (repodir) + "Read a list of checkpoints from REPODIR. +Return as a patchinfo list." + ;; If there are no checkpoints, it doesn't matter. + (ignore-errors + (with-open-stream (in (open-upath (upath-subdir repodir '("_darcs" "checkpoints") "inventory"))) + (format t "~&Reading checkpoints") + (loop for patch = (read-patchinfo in) + while patch collect patch + do (princ #\.))))) + +(defun find-remaining-patches (patchinfo-list checkpoint) + "Find the patches remaining after getting to CHECKPOINT." + ;; XXX: this is incorrect; the checkpoint isn't among ordinary patches. + (loop for tail on patchinfo-list + when (equalp (car tail) checkpoint) + return (cdr tail))) + +(defun copy-repo-patches (from to patchinfo-list) + "Copy patches from repository FROM to repository TO. +PATCHINFO-LIST is the list of patches in FROM to copy." + (format t "~&Copying ~A patches" (length patchinfo-list)) + ;; Assume that TO/_darcs/patches is created + (dolist (patch patchinfo-list) + (let ((filename (patchinfo-make-filename patch))) + (with-open-file (out (merge-pathnames + (make-pathname :directory (list :relative "_darcs" "patches") + :name filename) + to) + :direction :output :element-type '(unsigned-byte 8)) + (with-open-stream (in (open-upath + (upath-subdir from '("_darcs" "patches") filename) + :binary t)) + (fad:copy-stream in out)))) + (princ #\.))) + +(defun copy-checkpoint (from to checkpoint) + "Copy CHECKPOINT from repository FROM to repository TO. +CHECKPOINT is a patchinfo naming the checkpoint." + (let ((filename (patchinfo-make-filename checkpoint))) + (with-open-file (out (merge-pathnames + (make-pathname :directory '(:relative "_darcs" "checkpoints") + :name filename) + to) + :direction :output :element-type '(unsigned-byte 8)) + (with-open-stream (in (open-upath + (upath-subdir from '("_darcs" "checkpoints") filename) + :binary t)) + (fad:copy-stream in out))))) Added: cl-darcs/trunk/ifstar.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/ifstar.lisp Tue May 23 08:45:51 2006 @@ -0,0 +1,62 @@ +;; the if* macro used in Allegro: +;; +;; This is in the public domain... please feel free to put this definition +;; in your code or distribute it with your version of lisp. + +(defpackage :excl (:use :common-lisp) + (:export #:if* #:then #:thenret #:else #:elseif)) +(in-package :excl) + +(defvar if*-keyword-list '("then" "thenret" "else" "elseif")) + +(defmacro if* (&rest args) + (do ((xx (reverse args) (cdr xx)) + (state :init) + (elseseen nil) + (totalcol nil) + (lookat nil nil) + (col nil)) + ((null xx) + (cond ((eq state :compl) + `(cond ,@totalcol)) + (t (error "if*: illegal form ~s" args)))) + (cond ((and (symbolp (car xx)) + (member (symbol-name (car xx)) + if*-keyword-list + :test #'string-equal)) + (setq lookat (symbol-name (car xx))))) + + (cond ((eq state :init) + (cond (lookat (cond ((string-equal lookat "thenret") + (setq col nil + state :then)) + (t (error + "if*: bad keyword ~a" lookat)))) + (t (setq state :col + col nil) + (push (car xx) col)))) + ((eq state :col) + (cond (lookat + (cond ((string-equal lookat "else") + (cond (elseseen + (error + "if*: multiples elses"))) + (setq elseseen t) + (setq state :init) + (push `(t ,@col) totalcol)) + ((string-equal lookat "then") + (setq state :then)) + (t (error "if*: bad keyword ~s" + lookat)))) + (t (push (car xx) col)))) + ((eq state :then) + (cond (lookat + (error + "if*: keyword ~s at the wrong place " (car xx))) + (t (setq state :compl) + (push `(,(car xx) ,@col) totalcol)))) + ((eq state :compl) + (cond ((not (string-equal lookat "elseif")) + (error "if*: missing elseif clause "))) + (setq state :init))))) + Added: cl-darcs/trunk/inflate.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/inflate.lisp Tue May 23 08:45:51 2006 @@ -0,0 +1,776 @@ +;; -*- mode: common-lisp; package: util.zip -*- +;; +;; inflate.cl +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; This code 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 +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA +;; +;; +;; $Id: inflate.cl,v 1.1.4.2 2002/06/19 02:50:55 layer Exp $ + +;; Description: +;; inflate a stream of bytes which was compressed with the Deflate +;; algorithm +;; +;; john foderaro, August 2001 +;; +;;- This code in this file obeys the Lisp Coding Standard found in +;;- http://www.franz.com/~jkf/coding_standards.html +;;- + + + +#| +Programming interface: + +(inflate input-stream output-stream) +- the compressed information from the input-stream is read and + the uncompressed information is written to the output-stream +- both streams must support (unsigned-byte 8) element reading and writing + + +(skip-gzip-header input-stream) +- if the input stream is positioned on the header of a gzip'ed file + then skip that header. +- if the input stream is not positioned on a gzip header then nothing + is done. + +|# + + + +#| + The Deflate Compression Algorithm + +reference: http://www.gzip.org/zlib/rfc-deflate.html + +Basic idea: +Deflation is a means of compressing an octet sequence that +combines the LZ77 algorithm for marking common substrings and +Huffman coding to take advantage of different frequency of occurance +for each possible values in the file. +This algorithm may not be as easy to understand or as efficient +as the LZW compression algorithm but Deflate does have the big +advantage in that it is not patented. Thus Deflate is a very +widely used. Nowdays it's the most common compression method +used in Windows Zip programs (e.g. Winzip) and in the Unix gzip program. +Java jar files, being just zip files, also use this compression method. + + +Lempel-Ziv 1977 (LZ77): +An octet sequence often contains repeated subsequences. The LZ algorithm +compresses a file by replacing repeated substrings with (Length,Distance) +markers which mean during decompression: Go back Distance octets +in output stream and copy Length bytes to the output stream. + +Huffman Coding: +A Huffman code for a set of values V assigns a unique bitsequence +to each value in V. A bitsequence is a sequence of 0's and 1'. +An important property of Huffman codes is that if X is a bitsequence +for a value in V then no other value in V has a bitsequence +with X as a prefix of that sequence. This means that if you see +the bitsequence X in the stream you know that this denotes the value +v and you don't have to read any more bits. + + +Blocks: +A deflated file is a sequence of blocks. There are three types of +blocks: +1. uncompressed - The block simply contains the same sequence of +octets as were found in the input stream. This type of block +is useful when the input stream has already been compressed (e.g. +it's a jpg or gif file) as compressing a compressed file often +results in the file getting larger. + +2. compressed with fixed Huffman code - The block contains a +huffman-coded LZ77 compressed bitsequence. The huffman code +used is specified by the deflate algorithm. This type of block +is useful when the octet sequence is short since in that case +the overhead of creating a custom huffman code is more than is gained +by that custom code. + +3. compressed with a custom Huffman code - The block contains +a description of a Huffman code to be used in this block only +and then a Huffman-code LZ77 compressed bitsequence. The values +that describe the custome huffman tree are themselves huffman coded. + + + +|# + +(defpackage :util.zip (:use :common-lisp :excl) + (:export #:inflate + #:skip-gzip-header)) + + +(in-package :util.zip) + +(provide :inflate) + +(defun inflate (p op) + ;; user callable + ;; inflate the stream p into the stream op + ;; both streams should be unsigned-byte 8 + ;; + (let ((br (new-bit-reader p)) + (buffer (make-array (* 32 1024) :element-type '(unsigned-byte 8))) + (end 0)) + (loop + (if* (null (setq end (process-deflate-block br op buffer end))) + then ; last block, we're all done + (return))))) + + + + +;;; ------------ gzip support +; +; gzip preceeds files with a header and the only support we need +; give to handle gzip files is the ability to skip the header +; and get to the meat of the file + + +; gzip constants + +; compression strategies (only one supported) +(defconstant z_deflated 8) + +; flag bits +(defconstant gz_ascii_flags #x01) ; file probably ascii +(defconstant gz_head_crc #x02) ; header crc present +(defconstant gz_extra_field #x04) ; extra field present +(defconstant gz_orig_name #x08) ; original file name present +(defconstant gz_comment #x10) ; file comment present +(defconstant gz_reserved #xe0) ; no bits allowed on here + +(defun skip-gzip-header (p) + ;; If the next thing in the stream p is gzip header then skip + ;; past it and return t. + ;; If it's not a gzip header than return nil + ;; If it's starts to look like a gzip header but turns out to + ;; not be valid signal an error. Note that the first byte of + ;; a gzip header is an illegal byte to begin a deflated stream so + ;; that if the first byte matches a gzip header but the rest do not + ;; then the stream was positioned at neither a gzip header nor a + ;; deflated stream + ; + ;; see check_header in gzio.c in rpm zlib-1.1.3 (or variant) + ;; for details on what's in the header. + + (let (method flags) + + ; look for magic number + (if* (not (eql #x1f (read-byte p))) + then ; not a gzip header, may be a deflate block + (unread-char (code-char #x1f) p) + (return-from skip-gzip-header nil)) + + + ; now check the second magic number + (if* (not (eql #x8b (read-byte p))) + then (error "non gzip magic number")) + + (setq method (read-byte p) + flags (read-byte p)) + + (if* (or (not (eql method z_deflated)) + (not (zerop (logand flags gz_reserved)))) + then (error "bad method/flags in header")) + + ; discard time, xflags and os code */ + (dotimes (i 6) (read-byte p)) + + ; discard extra field if present + (if* (logtest flags gz_extra_field) + then (let ((length (+ (read-byte p) + (ash (read-byte p) 8)))) + (dotimes (i length) (read-byte p)))) + + (if* (logtest flags gz_orig_name) + then ; discard name of file, null terminated + (do ((val (read-byte p) (read-byte p))) + ((zerop val)))) + + (if* (logtest flags gz_comment) + then ; discard comment, null terminated + (do ((val (read-byte p) (read-byte p))) + ((zerop val)))) + + (if* (logtest flags gz_head_crc) + then ; discard header crc + (dotimes (i 2) (read-byte p))) + + ; success! + t + )) + +;;;----------- end gzip support + + + +;;;----------- support for reading bitfields from a stream + + +(defstruct bit-reader + stream + last-byte ; last byte read, possibly two combined bytes too + bits ; bits left of last byte to use + ) + +(defparameter *maskarray* + ;; for a bit length, mask off junk bits + (make-array 17 + :initial-contents + '(#x0 + #x1 #x3 #x7 #xf + #x1f #x3f #x7f #xff + #x1ff #x3ff #x7ff #xfff + #x1fff #x3fff #x7fff #xffff))) + +;; bit reader +(defun new-bit-reader (stream) + ; create and initialize bit reader + (make-bit-reader :stream stream :last-byte 0 :bits 0)) + +(defun reset-bit-reader (br) + ; clear out unused bit of the current byte + (setf (bit-reader-bits br) 0)) + +(defun read-bits (br count) + ;; return a value from the current bit reader. + ;; the count can be from 1 to 16 + ;; + + (if* (eql count 0) + then (return-from read-bits 0)) + + + (let ((last-byte (bit-reader-last-byte br)) + (bits (bit-reader-bits br))) + (loop + (if* (>= bits count) + then ;we have enough now + (if* (> bits count) + then ; we have some left over + (setf (bit-reader-last-byte br) + (ash last-byte (- count))) + (setf (bit-reader-bits br) (- bits count)) + (return (logand last-byte (svref *maskarray* count))) + else ; no bits left + (setf (bit-reader-bits br) 0) + (setf (bit-reader-last-byte br) 0) + (return last-byte) + ) + else ; need a new byte + (let ((new-byte (read-byte (bit-reader-stream br)))) + (setq last-byte (+ last-byte + (ash new-byte bits))) + (incf bits 8)))))) + + + +;;;----------- end bitfield reading + + + + +;;;----------- build constant tables needed by the algorithm + +;; The tables needed to decode length and distance values +;; A compressed file contains a sequence of literal character values +;; or (length,distance) pairs. The length is computed by taking +;; the length-value in the file and using these tables to bind +;; a base length value and the number of extra bits to read from the file +;; and then to add to the length value. +;; The same is done for distance. + +(defvar *base-length*) ; array mapping code to length value +(defvar *length-extra-bits*) ; array saying how many more bitsworth to read + +(defvar *base-distance*) +(defvar *distance-extra-bits*) + + +; build those arrays at load time: + +(progn + (setq *base-length* (make-array (1+ (- 285 257))) + *length-extra-bits* (make-array (1+ (- 285 257)))) + + (let ((len 3) + (ind 0)) + (dolist (ent '((8 0) ; count and number of extra bits + (4 1) (4 2) (4 3) (4 4) (4 5) (1 0))) + (dotimes (i (car ent)) + (setf (svref *base-length* ind) len) + (setf (svref *length-extra-bits* ind) (cadr ent)) + (incf ind 1) + (incf len (ash 1 (cadr ent))) + ) + ; special case, code 285 is length 258. + (setf (svref *base-length* (- 285 257)) 258) + )) + + (setq *base-distance* (make-array (1+ (- 29 0))) + *distance-extra-bits* (make-array (1+ (- 29 0)))) + + (let ((dist 1) + (ind 0)) + (dolist (ent '((4 0) ; count and number of extra bits + (2 1) (2 2) (2 3) (2 4) (2 5) (2 6) (2 7) (2 8) + (2 9) (2 10) (2 11) (2 12) (2 13))) + (dotimes (i (car ent)) + (setf (svref *base-distance* ind) dist) + (setf (svref *distance-extra-bits* ind) (cadr ent)) + (incf ind 1) + (incf dist (ash 1 (cadr ent))))))) + + + + +;;;----------- end table building + + + +;;;----------- Huffman tree support + +(defstruct (bitinfo (:type list)) + ;; when we describe a range of values and the code width we + ;; use a list of three elements. this structure describes it + minval + maxval + bitwidth) + + +;test case +; (generate-huffman-tree '((0 4 3) (5 5 2) (6 7 4))) +; will generate sample table from the Deutsch paper +; + +(defun generate-huffman-tree (bitinfo) + ;; bitinfo is a list of bitinfo items (minval maxval bitwidth) + ;; which means that values from minval through maxval are + ;; to be represented by codes of width bitwidth. + ;; + ;; we return two valuse: the huffman tree and the mininum bit width + ;; + (let ((maxval 0) + (minval most-positive-fixnum) + (maxbitwidth 0) + (minbitwidth most-positive-fixnum) + bitwidthcounts + valuecode + valuewidth + nextcode + ) + ; find out the range of values (well the max) and the max bit width + (dolist (bi bitinfo) + (setq maxval (max maxval (bitinfo-maxval bi))) + (setq minval (min minval (bitinfo-minval bi))) + (setq maxbitwidth (max maxbitwidth (bitinfo-bitwidth bi))) + (setq minbitwidth (min minbitwidth (bitinfo-bitwidth bi))) + ) + + ; per bitwidth arrays + (setq bitwidthcounts (make-array (1+ maxbitwidth) + :initial-element 0)) + (setq nextcode (make-array (1+ maxbitwidth) + :initial-element 0)) + + ; per value arrays + (setq valuecode (make-array (1+ (- maxval minval)))) ; huffman code chose + (setq valuewidth (make-array (1+ (- maxval minval)) + :initial-element 0)) ; bit width + + (dolist (bi bitinfo) + ; set valuewidth array from the given data + (do ((v (bitinfo-minval bi) (1+ v))) + ((> v (bitinfo-maxval bi))) + (setf (svref valuewidth (- v minval)) (bitinfo-bitwidth bi))) + + ; keep track of how many huffman codes will have a certain bit width + (incf (svref bitwidthcounts (bitinfo-bitwidth bi)) + (1+ (- (bitinfo-maxval bi) (bitinfo-minval bi)))) + ) + + + + ; compute the starting code for each bit width + (let ((code 0)) + (dotimes (widthm1 maxbitwidth) + (setq code + (ash (+ code (svref bitwidthcounts widthm1)) 1)) + (setf (svref nextcode (1+ widthm1)) code))) + + ; compute the huffman code for each value + (do ((v minval (1+ v))) + ((> v maxval)) + (let ((width (svref valuewidth (- v minval)))) + (if* (not (zerop width)) + then ; must assign a code + (setf (svref valuecode (- v minval)) + (svref nextcode width)) + (incf (svref nextcode width))))) + + ;; now we know the code for each value in the valuecode array + ;; + ;; now compute the tree + (values (build-huffman-tree + minval + (mapcar #'(lambda (bi) (cons (car bi) (cadr bi))) bitinfo) + valuecode valuewidth 1) + ; second value useful for decoding: + minbitwidth))) + + +(defun build-huffman-tree (minval minmaxes valuecode valuewidth pos) + ;; compute a huffman cons tree + ;; minmaxes is a list of conses. each cons + ;; representing a (min . max) range of values. + ;; + + (multiple-value-bind (zero one) (split-on-position minval minmaxes + valuecode + valuewidth + pos) + (cons (if* (consp zero) + then (build-huffman-tree minval + zero valuecode valuewidth (1+ pos)) + else zero) + (if* (consp one) + then (build-huffman-tree minval one valuecode valuewidth (1+ pos)) + else one)))) + +(defun split-on-position (minval minmaxes valuecode valuewidth pos) + ;; compute those values that have a zero in the pos (1 based) position + ;; of their code and those that have one in that position. + ;; return two values, the zero set and the one set. + ;; The position is from the msbit of the huffman code. + ;; + ;; If the value of the specified pos selects a specific value + ;; and no further bits need be read to identify that value then + ;; we return that value rather than a list of conses. + + (let (zero one) + (dolist (mm minmaxes) + (do ((v (car mm) (1+ v))) + ((> v (cdr mm))) + (let ((width (svref valuewidth (- v minval))) + (code (svref valuecode (- v minval)))) + (if* (logbitp (- width pos) code) + then ; one bit set + (if* (eql width pos) + then ; last bit + (setq one v) + else ; more bits to check + (let ((firstone (car one))) + (if* (and firstone + (eq (cdr firstone) (1- v))) + then ; increase renge + (setf (cdr firstone) v) + else (push (cons v v) one)))) + else ; zero bit set + (if* (eql width pos) + then ; last bit + (setq zero v) + else ; more bits to check + (let ((firstzero (car zero))) + (if* (and firstzero + (eq (cdr firstzero) (1- v))) + then ; increase renge + (setf (cdr firstzero) v) + else (push (cons v v) zero)))))))) + (values + (if* (consp zero) then (nreverse zero) else zero) ; order numerically + (if* (consp one) then (nreverse one) else one)))) + + +(defun generate-huffman-tree-from-vector (vector start end) + ;; generate huffman tree from items in the vector from start to end-1 + ;; assume start corresponds to value 0 in the tree + (do ((i start (1+ i)) + (val 0 (1+ val)) + (res)) + ((>= i end) + (generate-huffman-tree (nreverse res))) + (let ((len (svref vector i))) + (if* (> len 0) + then (push (list val val len) res))))) + + + + + +;; the huffman tree to use for type 1 blocks +;; +(defparameter *fixed-huffman-tree* + (generate-huffman-tree '((0 143 8) (144 255 9) (256 279 7) (280 287 8)))) + +;; distance are represented by a trivial huffman code +(defparameter *fixed-huffman-distance-tree* + (generate-huffman-tree '((0 31 5)))) + + +;;;----------- end Huffman support + + + + +(defun process-deflate-block (br op buffer end) + ;; br is a bit stream, op is the output stream + ;; process the next block in the stream + ;; return false if this is the last block of data else + ;; return the next index into the buffer + (let ((bfinal (read-bits br 1)) + (btype (read-bits br 2))) + + (setq end + (case btype + (0 (process-non-compressed-block br op buffer end)) + (1 (process-fixed-huffman-block br op buffer end)) + (2 (process-dynamic-huffman-block br op buffer end)) + (3 (error "illegal deflate block value")))) + (if* (eql bfinal 1) + then (flush-buffer op buffer end) + nil + else end) + )) + + + +(defun process-non-compressed-block (br op buffer end) + ;; process a block of uncompressed data + (reset-bit-reader br) + (let ((p (bit-reader-stream br))) + (let ((len (read-uword p)) + (onecomplen (read-uword p))) + (if* (not (eql len (logxor #xffff onecomplen))) + then (error "bad length value in non compressed block")) + (dotimes (i len) + (setq end (put-byte-in-buffer op (read-byte p) buffer end)))) + end)) + +(defun read-uword (stream) + ;; read a little endian value + (+ (read-byte stream) (ash (read-byte stream) 8))) + +(defun put-byte-in-buffer (op byte buffer end) + ;; store the next output byte in the buffer + (if* (>= end (length buffer)) + then (flush-buffer op buffer end) + (setq end 0)) + (setf (aref buffer end) byte) + (1+ end)) + +(defun flush-buffer (op buffer end) + ;; send bytes to the output stream. If op isn't a stream + ;; then it must be a function to funcall to take the bytes. + (if* (> end 0) + then (if* (streamp op) + then (write-sequence buffer op :end end) + else (funcall op buffer end)))) + + + + + +(defun process-fixed-huffman-block (br op buffer end) + ;; process a huffman block with the standard huffman tree + ;; + (process-huffman-block br op *fixed-huffman-tree* 7 *fixed-huffman-distance-tree* 5 + buffer end)) + +(defun process-huffman-block (br op + lengthlit-tree minwidth + distance-tree mindistwidth + buffer end) + ;; the common code for blocks of type 1 and 2 that does + ;; the decompression given a length/literal huffman tree + ;; and a distance huffman tree. + ;; If the distance tree is nil then we use the trivial huffman + ;; code from the algorithm. + ;; + (let* ((bufflen (length buffer)) + length + distance + ) + + + (loop + (let ((value (decode-huffman-tree br lengthlit-tree minwidth))) + (if* (< value 256) + then ; output and add to buffer + (setq end (put-byte-in-buffer op value buffer end)) + + elseif (eql value 256) + then (return) ; end of block + else ; we have a length byte + ; compute length, distance + + (let ((adj-code (- value 257))) + (setq length (+ (svref *base-length* adj-code) + (read-bits br (svref *length-extra-bits* + adj-code))))) + + (let ((dist-code (if* distance-tree + then (decode-huffman-tree br + distance-tree + mindistwidth) + else (read-bits br 5)))) + (setq distance + (+ (svref *base-distance* dist-code) + (read-bits br (svref *distance-extra-bits* + dist-code))))) + + ; copy in bytes + (do ((i (mod (- end distance) bufflen) (1+ i)) + (count length (1- count))) + ((<= count 0)) + (if* (>= i bufflen) then (setf i 0)) + (setq end (put-byte-in-buffer op + (aref buffer i) + buffer + end)))))) + ; return where we left off + end)) + + + +(defparameter *code-index* + ;; order of elements in the code index values + ;; pretty crazy, eh? + (make-array 19 + :initial-contents + '(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15))) + + +(defun process-dynamic-huffman-block (br op buffer end) + ;; process a block that includes a personalized huffman tree + ;; just for this block + (let ((hlit (read-bits br 5)) + (hdist (read-bits br 5)) + (hclen (read-bits br 4)) + + code-length-huffman-tree + (minlen 9999) + ) + + ; read in the huffman code width of each of the numbers + ; from 0 18... this will be then used to create a huffman tree + ; + (let ((codevec (make-array 19 :initial-element 0)) + (len)) + + (dotimes (i (+ hclen 4)) + (setf (svref codevec + (svref *code-index* i)) + (setq len (read-bits br 3))) + (if* (> len 0) then (setq minlen (min len minlen)))) + + + + (setq code-length-huffman-tree + (generate-huffman-tree-from-vector codevec 0 (length codevec)))) + + ; now we're in position to read the code lengths for the + ; huffman table that will allow us to read the data. + ; (Is this a nutty algorithm or what??) + ; + (let ((bigvec (make-array (+ hlit 257 hdist 1) + :initial-element 0)) + (index 0)) + (loop + (if* (>= index (length bigvec)) then (return)) + (let ((val (decode-huffman-tree br code-length-huffman-tree minlen))) + (if* (<= val 15) + then ; literal value + (setf (svref bigvec index) val) + (incf index) + elseif (eql val 16) + then ; repeat prev + (let ((prev-val (svref bigvec (1- index)))) + (dotimes (i (+ 3 (read-bits br 2))) + (setf (svref bigvec index) prev-val) + (incf index))) + elseif (eq val 17) + then ; repeat zero + (dotimes (i (+ 3 (read-bits br 3))) + (setf (svref bigvec index) 0) + (incf index)) + elseif (eq val 18) + then ; repeat zero a lot + (dotimes (i (+ 11 (read-bits br 7))) + (setf (svref bigvec index) 0) + (incf index))))) + + (let (literal-length-huffman litlen-width + distance-huffman distance-width) + (multiple-value-setq (literal-length-huffman litlen-width) + (generate-huffman-tree-from-vector bigvec 0 (+ hlit 257))) + + (multiple-value-setq (distance-huffman distance-width) + (generate-huffman-tree-from-vector bigvec (+ hlit 257) + (length bigvec))) + + (process-huffman-block br op literal-length-huffman litlen-width + distance-huffman distance-width + buffer end) + )))) + + + +(defun decode-huffman-tree (br tree minbits) + ;; find the next huffman encoded value. + ; the minimum length of a huffman code is minbits so + ; grab that many bits right away to speed processing and the + ; go bit by bit until the answer is found + (let ((startval (read-bits br minbits))) + (dotimes (i minbits) + (if* (logtest 1 startval) + then (setq tree (cdr tree)) + else (setq tree (car tree))) + (setq startval (ash startval -1))) + (loop + (if* (atom tree) + then (return tree) + else (if* (eql 1 (read-bits br 1)) + then (setq tree (cdr tree)) + else (setq tree (car tree))))))) + + + + + + +;;; test case... +;; Read file created with gzip and write the uncompressed version +;; to another file. +;; +;; Porting note: the open below works on ACL since it creates +;; a bivalent simple-stream. If you run this on other lispsj +;; you'll want to specify an :element-type of '(unsigned-byte 8) +;; +#+ignore +(defun testit (&optional (filename "foo.n.gz") (output-filename "out")) + (with-open-file (p filename :direction :input) + (skip-gzip-header p) + (with-open-file (op output-filename :direction :output + :if-exists :supersede) + (inflate p op)))) Added: cl-darcs/trunk/init.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/init.lisp Tue May 23 08:45:51 2006 @@ -0,0 +1,28 @@ +;;; 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 init-tree (treedir) + "Initialize TREEDIR for use as a Darcs tree." + ;; _darcs/current is actually a "pristine" directory + (dolist (dir '(("_darcs") ("_darcs" "patches") ("_darcs" "prefs") + ("_darcs" "current") "_darcs" "inventories")) + (make-dir (merge-pathnames + (make-pathname :directory (cons :relative dir)) + treedir))) + + (write-inventory treedir ())) Added: cl-darcs/trunk/invert-patch.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/invert-patch.lisp Tue May 23 08:45:51 2006 @@ -0,0 +1,86 @@ +;;; 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 invert-patch (patch) + (:documentation "Create a patch that is the inverse of PATCH.")) + +(defmethod invert-patch ((patch named-patch)) + (make-instance 'named-patch + :patchinfo (invert-patchinfo (named-patch-patchinfo patch)) + :dependencies (mapcar #'invert-patchinfo + (named-patch-dependencies patch)) + :patch (invert-patch (named-patch-patch patch)))) + +(defmethod invert-patch ((patch change-pref-patch)) + (make-instance 'change-pref-patch :pref (change-pref-which patch) + :from (change-pref-to patch) + :to (change-pref-from patch))) + +(defmethod invert-patch ((patch move-patch)) + (make-instance 'move-patch :from (patch-move-to patch) + :to (patch-move-from patch))) + +(defmethod invert-patch ((patch composite-patch)) + (make-instance 'composite-patch + :patches (mapcar #'invert-patch + (reverse (patches patch))))) + +(defmethod invert-patch ((patch split-patch)) + (make-instance 'split-patch + :patches (mapcar #'invert-patch + (reverse (patches patch))))) + +(defmethod invert-patch :around ((patch file-patch)) + (let ((inverted-patch (call-next-method))) + (setf (patch-filename inverted-patch) (patch-filename patch)) + inverted-patch)) + +(defmethod invert-patch ((patch hunk-patch)) + (make-instance 'hunk-patch + :line-number (hunk-line-number patch) + :old (hunk-new-lines patch) + :new (hunk-old-lines patch))) + +(defmethod invert-patch ((patch add-file-patch)) + (make-instance 'rm-file-patch)) + +(defmethod invert-patch ((patch rm-file-patch)) + (make-instance 'add-file-patch)) + +(defmethod invert-patch ((patch binary-patch)) + (make-instance 'binary-patch + :oldhex (binary-newhex patch) + :newhex (binary-oldhex patch))) + +(defmethod invert-patch ((patch token-replace-patch)) + (make-instance 'token-replace-patch + :regexp (token-regexp patch) + :old-token (old-token patch) + :new-token (new-token patch))) + +(defmethod invert-patch :around ((patch directory-patch)) + (let ((inverted-patch (call-next-method))) + (setf (patch-directory inverted-patch) (patch-directory patch)) + inverted-patch)) + +(defmethod invert-patch ((patch add-dir-patch)) + (make-instance 'rm-dir-patch)) + +(defmethod invert-patch ((patch rm-dir-patch)) + (make-instance 'add-dir-patch)) + Added: cl-darcs/trunk/packages.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/packages.lisp Tue May 23 08:45:51 2006 @@ -0,0 +1,7 @@ +(in-package :cl-user) + +(defpackage :darcs + (:use :cl) + (:nicknames :cl-darcs) + (:export + )) Added: cl-darcs/trunk/patch-core.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/patch-core.lisp Tue May 23 08:45:51 2006 @@ -0,0 +1,171 @@ +;;; 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) + +(defclass patch () + ()) + +(defclass composite-patch (patch) + ((patches :accessor patches :initarg :patches :initform () + :documentation "List of patches making up the composite patch."))) + +(defmethod print-object ((patch composite-patch) stream) + (if *print-readably* + (call-next-method) + (format stream "#<~A: ~W>" + (type-of patch) (patches patch)))) + +(defclass split-patch (patch) + ((patches :accessor patches :initarg :patches :initform ()))) + +(defclass file-patch (patch) + ((filename :accessor patch-filename :initarg :filename)) + (:documentation "Base class for patches affecting a single file.")) + +(defmethod print-object ((patch file-patch) stream) + (if *print-readably* (call-next-method) + (format stream "#<~A: ~A>" (type-of patch) (patch-filename patch)))) + +(defclass hunk-patch (file-patch) + ((line-number :accessor hunk-line-number :initarg :line-number + :documentation "Line number where hunk starts.") ;XXX: old or new? + (old :accessor hunk-old-lines :initarg :old + :documentation "The lines of the old version (list of strings)") + (new :accessor hunk-new-lines :initarg :new + :documentation "The lines of the new version (list of strings)")) + (:documentation "A single patch \"hunk\".")) + +(defmethod print-object ((patch hunk-patch) stream) + (if *print-readably* (call-next-method) + (format stream "#<~A: ~A ~A~[~:;~:*-~A~]~[~:;~:*+~A~]>" + (type-of patch) (patch-filename patch) + (hunk-line-number patch) + (length (hunk-old-lines patch)) + (length (hunk-new-lines patch))))) + +(defclass add-file-patch (file-patch) + () + (:documentation "A patch that creates a file.")) + +(defclass rm-file-patch (file-patch) + () + (:documentation "A patch that removes a file.")) + +(defclass binary-patch (file-patch) + ((oldhex :accessor binary-oldhex :initarg :oldhex + :type '(vector (unsigned-byte 8)) + :documentation "The old contents of the file.") + (newhex :accessor binary-newhex :initarg :newhex + :type '(vector (unsigned-byte 8)) + :documentation "The new contents of the file.")) + (:documentation "A patch that changes a binary file.")) + +(defclass token-replace-patch (file-patch) + ((regexp :accessor token-regexp :initarg :regexp) + (old-token :accessor old-token :initarg :old-token) + (new-token :accessor new-token :initarg :new-token)) + (:documentation "A patch that replaces one token with another.")) + +(defmethod print-object ((patch token-replace-patch) stream) + (if *print-readably* (call-next-method) + (format stream "#<~A: ~A: s/~A/~A/ (~S)>" (type-of patch) (patch-filename patch) + (old-token patch) (new-token patch) + (token-regexp patch)))) + +(defclass directory-patch (patch) + ((directory :accessor patch-directory :initarg :directory)) + (:documentation "Base class for patches affecting a directory.")) + +(defmethod print-object ((patch directory-patch) stream) + (if *print-readably* (call-next-method) + (format stream "#<~A: ~A>" (type-of patch) (patch-directory patch)))) + +(defclass add-dir-patch (directory-patch) + () + (:documentation "A patch that creates a directory.")) + +(defclass rm-dir-patch (directory-patch) + () + (:documentation "A patch that removes a directory.")) + +(defclass named-patch (patch) + ((patchinfo :accessor named-patch-patchinfo :initarg :patchinfo + :documentation "Metadata about this patch.") + (dependencies :accessor named-patch-dependencies :initarg :dependencies + :documentation "List of patchinfo structures naming the dependencies of this patch.") + (patch :accessor named-patch-patch :initarg :patch + :documentation "The patch itself.")) + (:documentation "A named patch.")) ;XXX: what does that mean? + +(defmethod print-object ((patch named-patch) stream) + (if *print-readably* + (call-next-method) + (let ((patchinfo (named-patch-patchinfo patch))) + (format stream "#<~A: ~A ~A: ~<~W~:>>" + (type-of patch) + (patchinfo-date patchinfo) + (patchinfo-name patchinfo) + (named-patch-patch patch))))) + +(defclass change-pref-patch (patch) + ((pref :initarg :pref :accessor change-pref-which) + (from :initarg :from :accessor change-pref-from) + (to :initarg :to :accessor change-pref-to)) + (:documentation "A patch for changing a preference.")) + +(defmethod print-object ((patch change-pref-patch) stream) + (if *print-readably* + (call-next-method) + (format stream "#<~A: ~A: s/~S/~S/>" + (type-of patch) + (change-pref-which patch) + (change-pref-from patch) + (change-pref-to patch)))) + +(defclass move-patch (patch) + ((from :initarg :from :accessor patch-move-from) + (to :initarg :to :accessor patch-move-to)) + (:documentation "A patch that moves a file.")) + +(defmethod print-object ((patch move-patch) stream) + (if *print-readably* + (call-next-method) + (format stream "#<~A: ~A -> ~A>" + (type-of patch) + (patch-move-from patch) + (patch-move-to patch)))) + +;; XXX: this class is probably incorrect and insufficient. +(defclass merger-patch (patch) + ((version :initarg :version :accessor merger-version) + (first :initarg :first :accessor merger-first) + (second :initarg :second :accessor merger-second) + (inverted :initarg :inverted :accessor merger-inverted) + (undo :initarg :undo :accessor merger-undo) + (unwindings :initarg :unwindings :accessor merger-unwindings))) + +(defmethod print-object ((patch merger-patch) stream) + (if *print-readably* + (call-next-method) + (format stream "#<~A ~A: ~A ~A>" + (type-of patch) + (merger-version patch) + (merger-first patch) + (merger-second patch)))) + +;; There are more kinds of patches... let's implement them when need +;; arises. Added: cl-darcs/trunk/patchinfo.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/patchinfo.lisp Tue May 23 08:45:51 2006 @@ -0,0 +1,117 @@ +;;; 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) + +;; defclass? +(defstruct patchinfo + date name author log inverted) + +;; make_filename in PatchInfo.lhs +(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)) + (sha1 (str) + (ironclad:byte-array-to-hex-string + (sha1-internal + (ironclad:ascii-string-to-byte-array str))))) + (concatenate 'string + ;; the original code uses cleanDate... but why? + date + "-" + (subseq (sha1 author) 0 5) + "-" + (sha1 + (concatenate + 'string + name author date + (apply #'concatenate 'string log) + (if inverted "t" "f"))) + ".gz")))) + +;; readPatchInfo in PatchInfo.lhs +(defun read-patchinfo (stream) + "Read a patch id from STREAM. +Return NIL if none found due to EOF." + ;; skip whitespace + (let ((c + (loop for c = (read-byte stream nil :eof) + while (and (not (eql c :eof)) (isspace c)) + finally (return c)))) + (cond + ;; EOF? + ((eql c :eof) + (return-from read-patchinfo nil)) + ;; First character must be [ + ((eql c (char-code #\[)) + ) + (t + (error "~S is not #\\[, no patchinfo read." (code-char c))))) + + (let ( ;; Now, the rest of the line is the name. + (name (read-binary-line stream)) + ;; And up to * is the author. + (author (read-until (char-code #\*) stream)) + ;; Next character is '*' (normal patch) or '-' (inverted patch) + (inverted (eql (read-byte stream) (char-code #\-)))) + ;; Up to end of line (modulo possible ]) is date + (multiple-value-bind (date char) (read-until (list 10 (char-code #\])) stream) + ;; If char is #\] here, we have no log. Else, the log is the + ;; following lines starting with a space. The line after the + ;; log starts with #\]. We should remove the space in front of + ;; each line. We need bit-by-bit quality, since the log is used + ;; for hashing later. + (dformat "~&Date terminated by ~A." char) + (let ((log (when (/= char (char-code #\])) + (loop + for line = (read-binary-line stream) + until (= (elt line 0) (char-code #\])) + do (dformat "~&Got line ~S." line) + do (when (or (zerop (length line)) + (/= (elt line 0) 32)) + (error "Malformed log line ~S." line)) + collect (bytes-to-string (subseq line 1)) + finally (unread-line stream (subseq line 1)))))) ;discard #\] + (make-patchinfo :date (bytes-to-string date) + :name (bytes-to-string name) + :author (bytes-to-string author) + :log log + :inverted inverted))))) + +(defun write-patchinfo (patchinfo stream) + "Write PATCHINFO to STREAM." + (write-char #\[ stream) + (write-line (patchinfo-name patchinfo) stream) + (write-string (patchinfo-author patchinfo) stream) + (write-string (if (patchinfo-inverted patchinfo) + "*-" + "**") + stream) + (write-string (patchinfo-date patchinfo) stream) + (when (patchinfo-log patchinfo) + (terpri stream) + (dolist (log (patchinfo-log patchinfo)) + (write-char #\Space stream) + (write-line log stream))) + (write-string "] " stream)) + +(defun invert-patchinfo (patchinfo) + "Make a copy of PATCHINFO with the inverted flag toggled." + (let ((copy (copy-patchinfo patchinfo))) + (setf (patchinfo-inverted copy) + (not (patchinfo-inverted copy))))) Added: cl-darcs/trunk/prefs.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/prefs.lisp Tue May 23 08:45: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 read-prefs (upath) + "Read all preferences from repository at UPATH. +Return an alist with strings." + (let ((stream (ignore-errors + (open-upath + (upath-subdir upath '("_darcs" "prefs") "prefs")))) + alist) + (when stream + (with-open-stream (in stream) + (loop for line = (read-line in nil) + while line + do (let ((pos (position #\Space line))) + (when pos + (let ((name (subseq line 0 pos)) + (value (subseq line (1+ pos)))) + (push (cons name value) alist))))))) + alist)) + +(defun get-pref (upath prefname) + "Get value of PREFNAME from repository at UPATH. +Return nil if no value was found." + (cdr (assoc prefname (read-prefs upath) :test #'string=))) + +(defun set-pref (repopath prefname value) + "Set value of PREFNAME to VALUE in REPOPATH." + (let* ((prefs (read-prefs repopath)) + (entry (assoc prefname prefs :test #'string=))) + (if entry + (setf (cdr entry) value) + (push (cons prefname value) prefs)) + (with-open-file (out (upath-subdir repopath '("_darcs" "prefs") "prefs") + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (dolist (pref prefs) + (format out "~A ~A~%" (car pref) (cdr pref)))))) Added: cl-darcs/trunk/read-patch.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/read-patch.lisp Tue May 23 08:45:51 2006 @@ -0,0 +1,283 @@ +;;; 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 read-patch-from-file (filename &key (compressed t)) + "Read a Darcs-style patch from FILENAME (a upath). +The file is expected to be compressed unless COMPRESSED is NIL." + (restart-case + (if compressed + ;; It's hard to switch between binary and text mode + ;; (element-type (unsigned-byte 8) and character, respectively). + ;; So decompress the file to a temporary file, and read it from + ;; there. + (with-temp-file-name tmp-file + (uncompress-file filename tmp-file) + (with-open-stream (uncompressed + (make-instance 'unreadable-stream + :base-stream (open-upath (pathname tmp-file) :binary t))) + (read-patch uncompressed))) + ;; Reading an uncompressed file is easier, but they don't appear + ;; in the wild. + (with-open-stream (uncompressed (make-instance 'unreadable-stream + :base-stream (open-upath filename :binary t))) + (read-patch uncompressed))) + (reread-patch () + :report (lambda (stream) + (format stream "Reread patch from ~A." filename)) + (read-patch-from-file filename :compressed compressed)))) + +;; from PatchRead.lhs +(defun read-patch (stream) + "Read a Darcs-style patch from STREAM." + ;; Read a whitespace-separated token... + (multiple-value-bind (token original) (read-token stream) + (dformat "~&Read ~S" token) + (cond + ((string= token "{") + ;; composite patch + (dformat "~&Reading composite patch") + (make-instance + 'composite-patch + :patches (loop for patch = (read-patch stream) + while patch collect patch))) + ((string= token "}") + ;; end of composite patch + nil) + + ((string= token "(") + ;; split patch + (make-instance + 'split-patch + :patches (loop for patch = (read-patch stream) + while patch collect patch))) + ((string= token ")") + ;; end of split patch + nil) + + ((string= token "hunk") + (read-hunk stream)) + + ((string= token "replace") + (read-token-replace stream)) + + ((string= token "binary") + (read-binary stream)) + + ((string= token "addfile") + (read-add-file stream)) + + ((string= token "adddir") + (read-add-dir stream)) + + ((string= token "rmfile") + (read-rm-file stream)) + + ((string= token "rmdir") + (read-rm-dir stream)) + + ((string= token "move") + (read-move stream)) + + ((string= token "changepref") + (read-change-pref stream)) + + ((string= token "merger") + (read-merger stream t)) + + ((string= token "regrem") + (read-merger stream nil)) + + ((string= token "conflict") + (read-conflict stream)) + + ((string= token "tcilfnoc") + (read-tcilfnoc stream)) + + ((char= (aref token 0) #\[) + ;; named patch. there is no space after [, so unread the + ;; token. + (unread-sequence stream original) + (read-named stream)) + + (t + (error "Unknown patch token ~S." token))))) + +(defun read-hunk (stream) + "Read a hunk patch from STREAM." + ;; Read file name and line number... + (let ((filename (read-token stream)) + (line-number (parse-integer (read-token stream))) + old new) + (dformat "~&Reading hunk for ~A" filename) + ;; Skip context (lines starting with space) + (loop for line = (read-binary-line stream) + while (= (elt line 0) 32) + finally (unread-line stream line)) + ;; Collect 'old' lines (starting with '-') + (setf old + (loop for line = (read-binary-line stream nil) + while (and line (= (elt line 0) (char-code #\-))) + collect (subseq line 1) + do (dformat ".") + finally (when line (unread-line stream line)))) + ;; Collect 'new' lines (starting with '+') + (setf new + (loop for line = (read-binary-line stream nil) + while (and line (= (elt line 0) (char-code #\+))) + collect (subseq line 1) + do (dformat ".") + finally (when line (unread-line stream line)))) + (make-instance + 'hunk-patch :filename (sanitize-filename filename) + :line-number line-number + :old old :new new))) + +(defun read-named (stream) + "Read a named patch." + ;; A named patch starts with a patchinfo. + (let ((patchinfo (read-patchinfo stream)) + dependencies) + (dformat "~&Reading named patch: ~A" patchinfo) + ;; If the next token is '<', it has a list of dependencies. + (multiple-value-bind (next-token maybe-unread-this) (read-token stream) + (if (string= next-token "<") + ;; The list of dependencies ends with '>'. + (loop for (next-token original) = + (multiple-value-list (read-token stream)) + until (string= next-token ">") + do (unread-sequence stream original) + (push (read-patchinfo stream) dependencies) + finally (setf dependencies (nreverse dependencies))) + ;; It wasn't '<', so unread it. + (unread-sequence stream maybe-unread-this))) + (dformat "~&Got dependencies: ~A" dependencies) + + ;; And then comes the patch itself. + (let ((patch (read-patch stream))) + (make-instance + 'named-patch :patchinfo patchinfo + :dependencies dependencies + :patch patch)))) + +(defun read-binary (stream) + "Read a binary patch." + ;; A binary patch consists of the token "oldhex", the old contents, + ;; "newhex", and the new contents. Contents is in lines starting + ;; with '*', hex-encoded. + (flet ((read-binary-data () + (let* ((bytes (make-array 1024 :element-type '(unsigned-byte 8) + :adjustable t :fill-pointer 0))) + (loop for line = (read-binary-line stream nil) + while (and line (= (elt line 0) (char-code #\*))) + do (loop for i from 1 below (length line) by 2 + do (vector-push-extend + (+ (* 16 (hex-to-number (elt line i))) + (hex-to-number (elt line (1+ i)))) + bytes)) + do (dformat ".") + finally (when line (unread-line stream line))) + bytes))) + (let ((filename (read-token stream))) + (dformat "~&Reading binary patch for ~A" filename) + (let ((oldhex (progn + + (read-token stream) + (read-binary-data))) + (newhex (progn (read-token stream) (read-binary-data)))) + (make-instance 'binary-patch + :filename (sanitize-filename filename) + :oldhex oldhex + :newhex newhex))))) + +(defun read-add-file (stream) + "Read an 'add file' patch." + (make-instance 'add-file-patch + :filename (sanitize-filename (read-token stream)))) + +(defun read-rm-file (stream) + "Read a 'remove file' patch." + (make-instance 'rm-file-patch + :filename (sanitize-filename (read-token stream)))) + +(defun read-add-dir (stream) + "Read an 'add directory' patch." + (make-instance 'add-dir-patch + :directory (sanitize-filename (read-token stream) + :type :directory))) + +(defun read-rm-dir (stream) + "Read a 'remove directory' patch." + (make-instance 'rm-dir-patch + :directory (sanitize-filename (read-token stream) + :type :directory))) + +(defun read-change-pref (stream) + "Read a 'change preferences' patch." + ;; Read the name. (assume that read-token gobbles the newline) + (let ((name (read-token stream)) + ;; Read old value. + (from (bytes-to-string (read-binary-line stream))) + ;; Read new value. + (to (bytes-to-string (read-binary-line stream)))) + (make-instance 'change-pref-patch :pref name :from from :to to))) + +(defun read-move (stream) + "Read a 'move file' patch." + (let ((from (sanitize-filename (read-token stream))) + (to (sanitize-filename (read-token stream)))) + (make-instance 'move-patch :from from :to to))) + +(defun read-merger (stream inverted) + "Read a merger patch." + ;; XXX: this needs much more work + (let ((version (read-token stream))) + (read-token stream) ; #$ + (let ((p1 (read-patch stream)) + (p2 (read-patch stream))) + (read-token stream) ; #$ + (let* ((is-merger1 (typep p1 'merger-patch)) + (is-merger2 (typep p2 'merger-patch)) + (undo + (cond + ((and is-merger1 is-merger2) + ;; TBD + nil + ) + ((and (not is-merger1) (not is-merger2)) + (invert-patch p1)) + ((and is-merger1 (not is-merger2)) + (make-instance 'composite-patch)) ;empty patch + ((and (not is-merger1) is-merger2) + (make-instance 'composite-patch + :patches (list (invert-patch p1) + (merger-undo p2))))))) + (make-instance 'merger-patch + :version version :first p1 :second p2 + :inverted inverted :undo undo))))) + +(defun read-token-replace (stream) + "Read a token replacing patch." + (let ((filename (sanitize-filename (read-token stream))) + (token-regexp (read-token stream)) + (old-token (read-token stream)) + (new-token (read-token stream))) + (make-instance 'token-replace-patch + :filename filename + :regexp (subseq token-regexp 1 (1- (length token-regexp))) + :old-token old-token + :new-token new-token))) Added: cl-darcs/trunk/touching.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/touching.lisp Tue May 23 08:45:51 2006 @@ -0,0 +1,55 @@ +;;; 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 :cl-darcs) + +(defgeneric find-touching (patch filename) + (: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))) + +(defmethod find-touching ((patch patch) filename) + "This least specific method returns NIL." + nil) + +(defmethod find-touching ((patch composite-patch) filename) + "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))) + (when touching-patches + (make-instance 'composite-patch :patches touching-patches)))) + +(defmethod find-touching ((patch file-patch) filename) + (when (equal filename (patch-filename patch)) + patch)) + +(defmethod find-touching ((patch directory-patch) filename) + (when (equal filename (patch-directory patch)) + patch)) + +(defmethod find-touching ((patch named-patch) filename) + (let ((touching-patch (find-touching (named-patch-patch patch) filename))) + (when touching-patch + (make-instance 'named-patch + :patchinfo (named-patch-patchinfo patch) + :dependencies (named-patch-dependencies patch) + :patch touching-patch)))) + Added: cl-darcs/trunk/unreadable-stream.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/unreadable-stream.lisp Tue May 23 08:45:51 2006 @@ -0,0 +1,146 @@ +;;; 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) + +(defclass unreadable-stream + (trivial-gray-streams:trivial-gray-stream-mixin + trivial-gray-streams:fundamental-binary-input-stream) + ((stream :initarg :base-stream) + (buffer :initform nil)) + (:documentation "A wrapper for a binary input stream. +Unlimited \"unreading\" is allowed through UNREAD-BYTE and +UNREAD-SEQUENCE.")) + +(defmethod trivial-gray-streams:stream-read-byte + ((stream unreadable-stream)) + (with-slots ((base-stream stream) buffer) stream + (let ((from-buffer (car buffer))) + ;; Has something been unread? + (cond + ;; No, nothing. + ((null from-buffer) + (read-byte base-stream nil :eof)) + ;; A single byte. + ((numberp from-buffer) + (pop buffer) + from-buffer) + ;; A sequence. + ((listp from-buffer) + ;; Get the byte from the indicated start index. + (prog1 + (elt (third from-buffer) (first from-buffer)) + (incf (first from-buffer)) + ;; If the sequence is exhausted, drop it. + (when (= (first from-buffer) (second from-buffer)) + ;; Wait - is there a terminating newline? + (if (eql (fourth from-buffer) :line) + ;; Preserve it. + (setf (car buffer) 10) + (pop buffer))))) + ;; Something else. + (t + (error "Invalid buffer entry ~S." from-buffer)))))) + +(defmethod trivial-gray-streams:stream-read-sequence + ((stream unreadable-stream) + sequence start end &key) + (with-slots ((base-stream stream) buffer) stream + (unless start (setf start 0)) + (unless end (setf end (length sequence))) + + ;; First, see if we can use the buffer. + (loop while (and (< start end) buffer) + do (let ((from-buffer (car buffer))) + ;; What do we find in the buffer? + (cond + ;; A single byte. + ((numberp from-buffer) + (setf (elt sequence start) from-buffer) + (incf start) + (pop buffer)) + ;; A sequence. + ((listp from-buffer) + (let* ((has-newline (eql (fourth from-buffer) :line)) + (len (min (- end start) + (- (second from-buffer) (first from-buffer))))) + (setf (subseq sequence start (+ start len)) + (subseq (third from-buffer) (+ (first from-buffer) len))) + (incf start len) + (incf (first from-buffer) len) + ;; If the sequence is exhausted, drop it. + (when (= (first from-buffer) (second from-buffer)) + (if (not has-newline) + (pop buffer) + ;; Is there space for the newline? + (if (< start end) + ;; Yes - line is entirely consumed. + (progn + (setf (elt sequence start) 10) + (incf start) + (pop buffer)) + ;; No - preserve the newline. + (setf (car buffer) 10))))))))) + + ;; If we need more data, get it from the base stream. + (if (< start end) + (read-sequence sequence base-stream :start start :end end) + ;; Otherwise, report that the sequence is full. + end))) + +#+nil (defmethod read-binary-line ((stream unreadable-stream) &optional (eof-error-p t) eof-value) + ;; If a line has been unread, we just return it. + (with-slots (buffer) stream + (let ((buffer-entry (car buffer))) + (if (and (listp buffer-entry) (eql (fourth buffer-entry) :line)) + ;; Yes! + (let ((start (first buffer-entry)) + (end (second buffer-entry)) + (sequence (third buffer-entry))) + (pop buffer) + ;; Simple case: it's a vector, and we haven't begun nibbling at it. + (if (and (vectorp sequence) (= (first buffer-entry) 0)) + sequence + ;; Otherwise, make a new vector. + (make-array (- end start) :element-type '(unsigned-byte 8) + :initial-contents (subseq sequence start)))) + ;; Oh well... + (call-next-method))))) + +(defmethod close ((stream unreadable-stream) &key abort) + "Close the underlying stream of STREAM." + (close (slot-value stream 'stream) :abort abort) + (call-next-method)) + +(defmethod unread-byte ((stream unreadable-stream) byte) + "Store BYTE at the head of the unread buffer." + (push byte (slot-value stream 'buffer))) + +(defmethod unread-sequence ((stream unreadable-stream) sequence) + "Store SEQUENCE at the head of the unread buffer. +It is assumed that SEQUENCE will not be modified." + (with-slots (buffer) stream + (push (list 0 (length sequence) sequence) buffer))) + +(defmethod unread-line ((stream unreadable-stream) line) + "Store LINE with an appended newline at the head of the unread buffer. +It is assumed that SEQUENCE will not be modified." + (with-slots (buffer) stream + (push (list 0 (length line) line :line) buffer))) + +(defmethod print-object ((object unreadable-stream) stream) + (if *print-readably* (call-next-method) + (format stream "#<~A ~A ~A>" (type-of object) (slot-value object 'buffer) (slot-value object 'stream)))) Added: cl-darcs/trunk/upath.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/upath.lisp Tue May 23 08:45:51 2006 @@ -0,0 +1,148 @@ +;;; 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) + +;; "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. + +(defun make-upath (path) + "Turn PATH into a \"universal pathname\". +If PATH is a pathname or URI, return it unchanged. +If PATH starts with \"http://\" or \"https://\", return a URI. +Else, return a pathname." + (ctypecase path + (pathname + path) + (puri:uri + path) + (string + (if (or (string= path "http://" :end1 7) + (string= path "https://" :end1 8)) + (puri:parse-uri path) + (pathname path))))) + +(defun upath-subdir (base subdirs &optional filename) + "From BASE, descend into SUBDIRS and FILENAME." + (setf base (make-upath base)) + (let* ((subdirs-list (remove-if #'keywordp + (if (pathnamep subdirs) + (pathname-directory subdirs) + subdirs)))) + (ctypecase base + (puri:uri + (let* ((current-path (puri: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 + (append new-path (list filename)) + new-path)) + new-uri)) + ;; this won't work correctly if BASE has a filename + (pathname + (merge-pathnames + (make-pathname :directory (cons :relative subdirs-list) + :name filename) + base))))) + +(defun open-upath (upath &key binary (redirect-max-depth 5)) + "Open UPATH for reading. Return a stream. +If BINARY is true, use an element type of (UNSIGNED-BYTE 8), +else CHARACTER." + (setf upath (make-upath upath)) + (ctypecase upath + (puri: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) + (let ((code (net.aserve.client:client-request-response-code client-request))) + (cond + ((= code 200) + (make-instance (if binary 'http-byte-input-stream 'http-char-input-stream) + :client-request client-request)) + ((and (> redirect-max-depth 0) (member code '(301 302 303 307))) + (let ((new-location (cdr (assoc :location (net.aserve.client:client-request-headers client-request))))) + (dformat "~&Redirected to ~A." new-location) + (net.aserve.client:client-request-close client-request) + (open-upath + (puri:uri new-location) + :redirect-max-depth (1- redirect-max-depth) :binary binary))) + (t + (error "Couldn't read ~A: ~A ~A." + upath + (net.aserve.client:client-request-response-code client-request) + (net.aserve.client:client-request-response-comment client-request))))))) + + (pathname + (open upath :direction :input :if-does-not-exist :error + :element-type (if binary '(unsigned-byte 8) 'character))))) + + +(defclass http-input-stream (trivial-gray-streams:trivial-gray-stream-mixin + trivial-gray-streams:fundamental-input-stream) + ((client-request :initarg :client-request) + (binary) + (unread :initform nil)) + (:documentation "A Gray stream wrapping an Allegroserve HTTP request.")) + +(defclass http-char-input-stream (http-input-stream + trivial-gray-streams:fundamental-character-input-stream) + ((binary :initform nil)) + (:documentation "An HTTP input stream for characters.")) + +(defclass http-byte-input-stream (http-input-stream + trivial-gray-streams:fundamental-binary-input-stream) + ((binary :initform t)) + (:documentation "An HTTP input stream for bytes.")) + +(defmethod trivial-gray-streams:stream-read-sequence + ((stream http-input-stream) sequence start end &key &allow-other-keys) + (if (slot-value stream 'binary) + (net.aserve.client:client-request-read-sequence + sequence (slot-value stream 'client-request)) + (let* ((buffer (make-array (- end start) :element-type '(unsigned-byte 8))) + (len (net.aserve.client:client-request-read-sequence + buffer (slot-value stream 'client-request)))) + (loop for i from 0 below len + do (setf (elt sequence (+ i start)) (aref buffer i))) + len))) + +(defmethod trivial-gray-streams:stream-read-byte ((stream http-input-stream)) + (let ((buffer (make-array 1 :element-type '(unsigned-byte 8)))) + (if (= 1 (trivial-gray-streams:stream-read-sequence stream buffer 0 1)) + (aref buffer 0) + :eof))) + +(defmethod trivial-gray-streams:stream-read-char ((stream http-input-stream)) + (or (pop (slot-value stream 'unread)) + (let ((byte (trivial-gray-streams:stream-read-byte stream))) + (if (eql byte :eof) byte (code-char byte))))) + +(defmethod trivial-gray-streams:stream-unread-char ((stream http-input-stream) char) + (push char (slot-value stream 'unread))) + +(defmethod stream-element-type ((stream http-input-stream)) + (if (slot-value stream 'binary) '(unsigned-byte 8) 'character)) + +(defmethod close ((stream http-input-stream) &key &allow-other-keys) + (net.aserve.client:client-request-close (slot-value stream 'client-request)) + (call-next-method)) Added: cl-darcs/trunk/util.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/util.lisp Tue May 23 08:45:51 2006 @@ -0,0 +1,211 @@ +;;; 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) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter +debugged-modules+ '(get #|read-patch patchinfo|# apply-patch #|init upath|# util) + "Modules emitting debug output.")) + +(defvar *http-proxy* nil + "HTTP proxy to use. +This should be either NIL or \"proxy.example.com:3128\".") + +(defmacro dformat (&rest format-args) + "Print FORMAT-ARGS to standard output if debugging applies." + (let ((pathname (or (and (boundp '*load-pathname*) *load-pathname*) + (and (boundp '*compile-file-pathname*) *compile-file-pathname*) + t))) ;loaded in repl + (when (or (eql pathname t) + (member (string-upcase (pathname-name pathname)) + +debugged-modules+ :test #'string=)) + `(format t ,@format-args)))) + +(defun isspace (c) + (ctypecase c + (character + (member c '(#\Space #\Tab #\Newline #\Linefeed))) + (number + (member c '(32 9 10 13))))) + +(defun hex-to-number (c) + "Turn C, the octet value of a hex digit, into the corresponding number." + (cond + ((<= (char-code #\0) c (char-code #\9)) + (- c (char-code #\0))) + ((<= (char-code #\A) c (char-code #\F)) + (- c (char-code #\A))) + ((<= (char-code #\a) c (char-code #\f)) + (- c (char-code #\a))) + (t + (error "Invalid hex digit ~A." c)))) + +(defun make-matcher (delimiters) + "Return a predicate based on DELIMITERS. +If DELIMITERS is an atom, checks for equality. +If DELIMITERS is a list, checks for membership. +If DELIMITERS is a function, returns it unchanged." + (ctypecase delimiters + (function delimiters) + (atom (lambda (c) (eql c delimiters))) + (list (lambda (c) (member c delimiters))))) + +(defun bytes-to-string (sequence) + "Convert SEQUENCE, a sequence of binary values, to a string." + (map 'string #'code-char sequence)) + +;; These functions read vaguely character-like data from binary +;; streams. + +(defun read-until (delimiters stream &optional (eof-error-p t) eof-value) + "Read from STREAM until encountering DELIMITERS. +DELIMITERS is an atom or a list of atoms, or a predicate function. + +Returns two values: + - vector of elements read + - encountered delimiter, or EOF-VALUE" + (let ((predicate (make-matcher delimiters)) + (bytes (make-array 80 :element-type '(unsigned-byte 8) + :adjustable t :fill-pointer 0))) + (loop for char = (read-byte stream eof-error-p) + while (and char (not (funcall predicate char))) + do (vector-push-extend char bytes) + finally (return (values bytes (or char eof-value)))))) + +(defmethod read-binary-line ((stream stream) &optional (eof-error-p t) eof-value) + "Read from STREAM until encountering a newline or end-of-file. +Return a vector of binary values. Return EOF-VALUE if EOF-ERROR-P +is nil and end-of-file occurs before any data is read." + (multiple-value-bind (line delim) + (read-until 10 stream eof-error-p eof-value) + (if (or (not (zerop (length line))) (eql delim 10)) + line + delim))) + +(defun read-token (stream) + "Read and return a whitespace-separated token from STREAM. +The first value returned is a string containing the token, +without the terminating whitespace. +The second value is a list of bytes containing the token and +the terminating whitespace. +STREAM is assumed to be an UNREADABLE-STREAM." + (loop for i = (read-byte stream) + while (isspace i) + finally (unread-byte stream i)) + (multiple-value-bind (token char) + (read-until #'isspace stream) + (values + (bytes-to-string token) + (progn + (vector-push-extend char token) + token)))) + +(defun uncompress-file (infile outfile) + "Uncompress INFILE (a gzipped file) and write contents to OUTFILE." + (setf infile (make-upath infile)) + (cond + #+clisp + ((pathnamep infile) + ;; C gunzip is magnitudes faster than the Lisp implementation, at + ;; least in CLISP. + (dformat "~&Uncompressing ~A through external program..." infile) + (ext:run-program "gunzip" :input (namestring infile) :output (namestring outfile) + :if-output-exists :error) + (dformat "done")) + (t + (dformat "~&Uncompressing ~A through Lisp function..." infile) + (with-open-stream (in (open-upath infile :binary t)) + (with-open-file (out outfile :direction :output :element-type '(unsigned-byte 8) + :if-exists :error) + (util.zip:skip-gzip-header in) + (util.zip:inflate in out) + (dformat "done")))))) + +(defun make-temp-file-name () + "Create a random name for a temporary file. +This is hopefully random enough to avoid problems." + ;; this ought to be fine, though unix-specific... + (make-pathname :directory '(:absolute "tmp") + :name (format nil "~A" (random most-positive-fixnum)))) + +(defun make-temp-file (&rest options) + "Open a temporary file with the given OPTIONS. +If OPTIONS specifies no direction, :OUTPUT is assumed." + (let ((filename (make-temp-file-name)) + (options (if (getf options :direction) + options + (cons :direction (cons :output options))))) + (apply 'open filename :direction :io options))) + +(defmacro with-temp-file-name (filename-variable &body body) + "Bind FILENAME-VARIABLE to a name generated by +MAKE-TEMP-FILE-NAME. +Delete that file after executing BODY." + `(let ((,filename-variable (make-temp-file-name))) + (unwind-protect + (progn + ,@body) + (delete-file ,filename-variable)))) + +(defmacro with-temp-file ((stream &rest options) &body body) + "Open a temporary file and bind the stream to STREAM. +Execute BODY, and remove the file." + `(let ((,stream (make-temp-file ,@options))) + (unwind-protect + (progn + ,@body) + (close ,stream) + (delete-file ,stream)))) + +(defun sanitize-filename (filename &key (type :file)) + "Convert FILENAME into a pathname. +Signal an error if FILENAME doesn't denote a relative path going +strictly down. +If TYPE is :DIRECTORY, return pathname in directory form." + (let ((components (split-sequence:split-sequence #\/ filename))) + (setf components (delete "." components :test #'string=)) + (when (member ".." components :test #'string=) + (error "Filename ~S tries to go up in directory tree." filename)) + (ecase type + (:directory + (make-pathname :directory (cons :relative components))) + (:file + (let* ((directory (butlast components)) + (filename (car (last components))) + (last-dot (position #\. filename :from-end t)) + (filename-without-dot + (if (and last-dot (/= 0 last-dot)) + (subseq filename 0 last-dot) filename)) + (type + (when (and last-dot (/= 0 last-dot)) + (subseq filename (1+ last-dot))))) + (make-pathname :directory (cons :relative directory) + :name filename-without-dot :type type)))))) + +(defun make-dir (pathname) + "Create directory PATHNAME." + (with-simple-restart (ignore-error "Ignore ~A directory creation error." pathname) + #+clisp (ext:make-dir pathname) + #+sbcl (sb-posix:mkdir pathname #o777) + #-(or clisp sbcl) + (error "MAKE-DIR not implemented for ~A." (lisp-implementation-type)))) + +(defun delete-dir (pathname) + "Delete directory PATHNAME." + #+clisp (ext:delete-dir pathname) + #+sbcl (sb-posix:rmdir pathname) + #-(or clisp sbcl) + (error "DELETE-DIR not implemented for ~A." (lisp-implementation-type)))

1 0