source: cl-darcs/tags/0.2.0/diff.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 diff-file (original modified &key filename)
  "Find changes between ORIGINAL and MODIFIED.
Return a list of HUNK-PATCHes.  Use FILENAME as their filename."
  (setf original (make-upath original))
  (setf modified (make-upath modified))
  (let* ((original-lines
          (if (fad:file-exists-p 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 (fad:file-exists-p 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
       ;; XXX: should we automatically add such files?
       (list
        (make-instance 'add-file-patch
                       :filename filename)
        (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 ())
        (make-instance 'rm-file-patch
                       :filename filename)))
      (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.
Use FILENAME as their filename.
Return a list of one BINARY-PATCH, or an empty list if
the files are equal."
  (with-open-file (o original
                      :direction :input :if-does-not-exist :error
                      :element-type '(unsigned-byte 8))
    (with-open-file (m modified
                       :direction :input :if-does-not-exist :error
                       :element-type '(unsigned-byte 8))
      (let ((o-contents
             (make-array (file-length o)
                         :element-type '(unsigned-byte 8)))
            (m-contents
             (make-array (file-length m)
                         :element-type '(unsigned-byte 8))))
        (read-sequence o-contents o)
        (read-sequence m-contents m)
        (unless (equalp o-contents m-contents)
          (list
           (make-instance 'binary-patch
                          :filename filename
                          :oldhex o-contents
                          :newhex m-contents)))))))

(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 (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))
         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 current directory, both in the
      ;; original and the modified tree, and get the union.
      (let* ((files-in-original 
              (mapcar #'original-to-repo-relative
                      (fad:list-directory original)))
             (files-in-modified 
              (mapcar #'modified-to-repo-relative
                      (fad:list-directory modified)))
             (files (nunion files-in-original files-in-modified
                            :test #'equal)))
        ;; Then we iterate through the union.
        (dolist (file files)
          (let ((original-pathname 
                 (merge-pathnames file pristine))
                (modified-pathname
                 (merge-pathnames file repo))
                (pathname-string
                 (pathname-to-string file)))
            (unless (file-boring-p repo pathname-string)
              (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*)))