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

;;; Copyright (C) 2006, 2007, 2008 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-stream (,instreamvar
                              (make-instance 'unreadable-stream
                                             :base-stream
                                             (open ,filename-gensym
                                                   :direction :input
                                                   :if-does-not-exist :error
                                                   :element-type '(unsigned-byte 8))
                                             :haskellish-lines t))
             ;; Open a temporary file for writing.
             (with-temp-file (,outstreamvar :element-type '(unsigned-byte 8))
               (progn ,@body)

               (close ,instreamvar)
               (close ,outstreamvar)

               (setf ,files-copied-gensym t)
               ;; Copy the temporary file over the original.
               (fad:copy-file (pathname ,outstreamvar) ,filename :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)
  ;; Maybe we're applying the patch to a pristine directory, in which
  ;; case we don't care about preferences.
  (when (has-prefs-dir 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)
    (with-open-file (f new-file :direction :output
                       :if-does-not-exist :create
                       :if-exists :error)
      (declare (ignore f)))))

(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)))))
        (cerror "Write new contents to ~A anyway."
                "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)))
    
    ;; In Lispworks, this works for both files and directories.
    #+lispworks (rename-file from to)

    #-(or clisp sbcl lispworks)
    (error "Applying a MOVE-PATCH is not implemented for ~A." (lisp-implementation-type))))

(defmethod apply-patch ((patch token-replace-patch) repodir)
  "Apply a token replace patch to a file in REPODIR."
  (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)
      (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)
                     (write-byte 10 out))))
          (loop
             (let ((line (read-binary-line in nil :eof)))
               (when (eql line :eof)
                 (return))
               (maybe-terpri)

               (setf line (bytes-to-string line))
               (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))
               
               (let ((patched-line (cl-ppcre:regex-replace-all old-regexp line replacement)))
                 (write-sequence (string-to-bytes 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...")
  (loop while patches
     do
     (etypecase (car patches)
       (hunk-patch
        (let ((filename (patch-filename (car patches)))
              (line-number 0))
          (loop while (and (typep (car patches) 'hunk-patch)
                           (equal (patch-filename (car patches)) filename)
                           (>= (hunk-line-number (car patches)) line-number))
             collect (car patches) into hunks
             do (setf line-number (+
                                   (hunk-line-number (car patches))
                                   (length (hunk-new-lines (car patches)))))
             (setf patches (cdr patches))
             finally (loop
                        (restart-case
                            (progn
                              (apply-hunk-list hunks repodir)
                              (return))
                          (retry-hunks ()
                            :report (lambda (stream)
                                      (format stream "Retry patch ~A to ~A" hunks filename))))))))
       (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.  The obvious way to do it would
            ;; be to print the lines to output, increasing the line
            ;; counter for every line.  However, in some circumstances
            ;; there are two subsequent hunks modifying the same line
            ;; (i.e. s/A/B/ and s/B/C/ are expected to have the same
            ;; result as s/A/C/), so we unread the lines instead.
            (dolist (new (reverse (hunk-new-lines hunk)))
              (unread-line in new)))

          ;; And output the lines after all hunks
          (loop for line = (read-binary-line in nil :eof)
             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)
    
    ;; After this comes "glump".  As long as version is "0.0", it
    ;; doesn't do anything.
    (assert (string= (merger-version patch) "0.0"))))