[Cl-darcs-cvs] r1 - in cl-darcs: . branches tags trunk
mhenoch at common-lisp.net
mhenoch at common-lisp.net
Tue May 23 12:45:52 UTC 2006
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 , at 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 at 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 at 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 , at 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 , at 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) , at 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 , at 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
+ , at 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 , at options)))
+ (unwind-protect
+ (progn
+ , at 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)))
More information about the Cl-darcs-cvs
mailing list