source: cl-darcs/trunk/diff.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)

(defun diff-file (original modified &key filename)
  "Find changes between ORIGINAL and MODIFIED.
Return a list of HUNK-PATCHes.  Use FILENAME as their filename."
  (when original (setf original (make-upath original)))
  (when modified (setf modified (make-upath modified)))
  (let* ((original-lines
          (if original
              (with-open-stream (in (open-upath original :binary t))
                (loop for line = (read-binary-line in nil)
                   while line collect line))
              :nonexistent))
         (modified-lines
          (if modified
              (with-open-stream (in (open-upath modified :binary t))
                (loop for line = (read-binary-line in nil)
                   while line collect line))
              :nonexistent))

         ;; using equalp is safe (i.e. non-case-clobbering), as
         ;; we use bytes instead of characters
         (opcodes (when (and (listp original-lines)
                             (listp modified-lines))
                    (difflib:get-opcodes
                     (make-instance 'difflib:sequence-matcher
                                    :a original-lines
                                    :b modified-lines
                                    :test-function #'equalp))))

         patches)
    (cond
      ((and (eql original-lines :nonexistent)
            (eql modified-lines :nonexistent))
       (error "Neither ~A nor ~A exist." original modified))
      ((eql original-lines :nonexistent)
       ;; Newly created file
       (list
        (make-instance 'hunk-patch
                       :filename filename
                       :line-number 1
                       :old ()
                       :new modified-lines)))
      ((eql modified-lines :nonexistent)
       ;; Removed file
       (list
        (make-instance 'hunk-patch
                       :filename filename
                       :line-number 1
                       :old original-lines
                       :new ())))
      (t
       ;; Possibly changed file
       (dolist (opcode opcodes)
         (unless (eql (difflib:opcode-tag opcode) :equal)
           (push 
            (make-instance 'hunk-patch
                           :filename filename
                           :line-number (1+ (difflib:opcode-j1 opcode))
                           :old (subseq original-lines
                                        (difflib:opcode-i1 opcode)
                                        (difflib:opcode-i2 opcode))
                           :new (subseq modified-lines
                                        (difflib:opcode-j1 opcode)
                                        (difflib:opcode-j2 opcode)))
            patches)))

       (nreverse patches)))))

(defun diff-binary-file (original modified &key filename)
  "Find changes between binary files ORIGINAL and MODIFIED.
ORIGINAL and MODIFIED can be NIL, meaning an empty file.
Use FILENAME as their filename.
Return a list of one BINARY-PATCH, or an empty list if
the files are equal."
  (let ((o-contents
         (when original
           (with-open-file (o original
                              :direction :input :if-does-not-exist :error
                              :element-type '(unsigned-byte 8))
             (let ((data
                    (make-array (file-length o)
                                :element-type '(unsigned-byte 8))))
               (read-sequence data o)))))
        (m-contents
         (when modified
           (with-open-file (m modified
                              :direction :input :if-does-not-exist :error
                              :element-type '(unsigned-byte 8))
             (let ((data 
                    (make-array (file-length m)
                                :element-type '(unsigned-byte 8))))
               (read-sequence data m)))))
        (empty (make-array 0 :element-type '(unsigned-byte 8))))
    (unless (equalp o-contents m-contents)
      (list
       (make-instance 'binary-patch
                      :filename filename
                      :oldhex (or o-contents empty)
                      :newhex (or m-contents empty))))))

(defun diff-repo (repo &optional original modified)
  "Find changes in REPO from pristine tree.
Return a list of patches.
ORIGINAL and MODIFIED specify directories to start from."
  (setf repo (truename (fad:pathname-as-directory repo)))
  (unless (and original modified)
    (setf modified repo)
    (setf original (upath-subdir repo '("_darcs" "pristine"))))

  (let* ((wild (make-pathname :directory '(:relative :wild-inferiors)
                              :name :wild
                              :type :wild
                              :version :wild))
         (repo-wild (merge-pathnames wild repo))
         (pristine (upath-subdir repo '("_darcs" "pristine")))
         (pristine-wild (merge-pathnames wild pristine))
         (original-wild (merge-pathnames wild original))
         (modified-wild (merge-pathnames wild modified))
         (pending (or 
                   (read-pending repo)
                   (make-instance 'composite-patch :patches ())))
         patches)
    ;; XXX: check if both directories exist

    ;; With fad:list-directory, we get absolute pathnames.  We make
    ;; them relative to the "root", so they can be compared.
    (flet ((original-to-repo-relative (p)
             (pathname (enough-namestring p pristine)))
           (modified-to-repo-relative (p)
             (pathname (enough-namestring p repo))))
      ;; We list the files in the original tree.
      (let* ((files-in-original 
              (mapcar #'original-to-repo-relative
                      (fad:list-directory original)))
             pruned-pending)
        ;; Create patch objects for newly added files and directories,
        ;; and remember pending patches not creating new files or
        ;; directories.
        (dolist (p (patches pending))
          (typecase p
            (add-file-patch
             (let ((pathname-string (pathname-to-string (patch-filename p)))
                   (old-file (merge-pathnames (patch-filename p) pristine))
                   (new-file (merge-pathnames (patch-filename p) repo)))
               (when (fad:file-exists-p old-file)
                 (error "Pending add of file ~A, but it already exists in the repository." pathname-string))
               (setf patches 
                     (nconc patches
                            (list* p
                                   (if (file-binary-p repo pathname-string)
                                       (diff-binary-file nil new-file :filename pathname-string)
                                       (diff-file nil new-file :filename pathname-string)))))))
            (add-dir-patch
             (let ((pathname-string (pathname-to-string (patch-directory p)))
                   (old-dir (merge-pathnames (patch-directory p) pristine)))
               (when (fad:directory-exists-p old-dir)
                 (error "Pending add of directory ~A, but it already exists in the repository." pathname-string)))
             (setf patches (nconc patches (list p))))
            (t
             (push p pruned-pending))))
        (setf (patches pending) (nreverse pruned-pending))

        ;; Then for each original file, find out its fate.
        (dolist (file files-in-original)
          ;; Was it touched by some "pending" patch?
          (multiple-value-bind (touching new-name)
              (find-touching pending file :forwards)
            (if touching
                ;; If yes, we want to record those patches, and remember the new name.
                (setf patches (nconc patches (patches touching)))
                ;; If not, it has the same name as before.
                (setf new-name file))

            (let ((original-pathname 
                   (merge-pathnames file pristine))
                  (modified-pathname
                   (merge-pathnames new-name repo))
                  (pathname-string
                   (pathname-to-string new-name)))
              (cond
                ((fad:directory-pathname-p file)
                 (setf patches (nconc patches
                                      (diff-repo repo original-pathname modified-pathname))))

                ((file-binary-p repo pathname-string)
                 (setf patches (nconc patches
                                      (diff-binary-file original-pathname
                                                        modified-pathname
                                                        :filename pathname-string))))

                (t
                 (setf patches (nconc patches 
                                      (diff-file original-pathname
                                                 modified-pathname
                                                 :filename pathname-string))))))))

        patches))))

(defun diff-repo-display (repo)
  "Find changes in REPO and print them to *STANDARD-OUTPUT*."
  (dolist (patch (diff-repo repo))
    (display-patch patch *standard-output*)))