source: cl-darcs/trunk/read-patch.lisp

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

      ((string= token "regrem")
       (read-merger stream t))

      ((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 ((merger (make-instance 'merger-patch
                                   :version version :first p1 :second p2
                                   :inverted inverted)))
        (let* ((is-merger1 (typep p1 'merger-patch))
               (is-merger2 (typep p2 'merger-patch)))
          (setf (merger-undo merger)
                (cond
                  ((and is-merger1 is-merger2)
                   (make-instance 'composite-patch
                                  :patches (mapcar #'invert-patch
                                                   (cdr (unwind merger)))))
                  ((and (not is-merger1) (not is-merger2))
                   (invert-patch p1))
                  ((and is-merger1 (not is-merger2))
                   (make-instance 'composite-patch)) ;empty patch
                  ((and (not is-merger1) is-merger2)
                   (make-instance 'composite-patch
                                  :patches (list (invert-patch p1)
                                                 (merger-undo p2)))))))
        merger))))

(defun read-token-replace (stream)
  "Read a token replacing patch."
  (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)))