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