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

(defclass patch ()
  ())

(defclass composite-patch (patch)
  ((patches :accessor patches :initarg :patches :initform ()
            :documentation "List of patches making up the composite patch.")))

(defmethod print-object ((patch composite-patch) stream)
  (print-unreadable-object (patch stream :type t)
    (write (patches patch) :stream stream)))

(defclass split-patch (patch)
  ((patches :accessor patches :initarg :patches :initform ())))

(defclass file-patch (patch)
  ((filename :accessor patch-filename :initarg :filename :type pathname))
  (:documentation "Base class for patches affecting a single file."))

(defmethod print-object ((patch file-patch) stream)
  (print-unreadable-object (patch stream :type t)
    (princ (patch-filename patch) stream)))

(defclass hunk-patch (file-patch)
  ((line-number :accessor hunk-line-number :initarg :line-number
                :documentation "Line number where hunk starts.") ;XXX: old or new?
   (old :accessor hunk-old-lines :initarg :old
        :documentation "The lines of the old version (list of strings)")
   (new :accessor hunk-new-lines :initarg :new
        :documentation "The lines of the new version (list of strings)"))
  (:documentation "A single patch \"hunk\"."))

(defmethod print-object ((patch hunk-patch) stream)
  (print-unreadable-object (patch stream :type t)
    (format stream "~A ~A~[~:;~:*-~A~]~[~:;~:*+~A~]"
            (patch-filename patch)
            (hunk-line-number patch)
            (length (hunk-old-lines patch))
            (length (hunk-new-lines patch)))))

(defclass add-file-patch (file-patch)
  ()
  (:documentation "A patch that creates a file."))

(defclass rm-file-patch (file-patch)
  ()
  (:documentation "A patch that removes a file."))

(defclass binary-patch (file-patch)
  ((oldhex :accessor binary-oldhex :initarg :oldhex
           :type (vector (unsigned-byte 8))
           :documentation "The old contents of the file.")
   (newhex :accessor binary-newhex :initarg :newhex
           :type (vector (unsigned-byte 8))
           :documentation "The new contents of the file."))
  (:documentation "A patch that changes a binary file."))

(defclass token-replace-patch (file-patch)
  ((regexp :accessor token-regexp :initarg :regexp :type string)
   (old-token :accessor old-token :initarg :old-token :type string)
   (new-token :accessor new-token :initarg :new-token :type string))
  (:documentation "A patch that replaces one token with another."))

(defmethod print-object ((patch token-replace-patch) stream)
  (print-unreadable-object (patch stream :type t)
    (format stream "~A: s/~A/~A/ (~S)"
            (patch-filename patch)
            (old-token patch) (new-token patch)
            (token-regexp patch))))

(defclass directory-patch (patch)
  ((directory :accessor patch-directory :initarg :directory))
  (:documentation "Base class for patches affecting a directory."))

(defmethod print-object ((patch directory-patch) stream)
  (print-unreadable-object (patch stream :type t)
    (princ (patch-directory patch) stream)))

(defclass add-dir-patch (directory-patch)
  ()
  (:documentation "A patch that creates a directory."))

(defclass rm-dir-patch (directory-patch)
  ()
  (:documentation "A patch that removes a directory."))

(defclass named-patch (patch)
  ((patchinfo :accessor named-patch-patchinfo :initarg :patchinfo
              :documentation "Metadata about this patch.")
   (dependencies :accessor named-patch-dependencies :initarg :dependencies
                 :documentation "List of patchinfo structures naming the dependencies of this patch.")
   (patch :accessor named-patch-patch :initarg :patch
          :documentation "The patch itself."))
  (:documentation "A named patch."))    ;XXX: what does that mean?

(defmethod print-object ((patch named-patch) stream)
  (print-unreadable-object (patch stream :type t)
    (let ((patchinfo (named-patch-patchinfo patch)))
      (format stream "~A ~A: ~<~W~:>"
              (patchinfo-date patchinfo)
              (patchinfo-name patchinfo)
              (named-patch-patch patch)))))

(defclass change-pref-patch (patch)
  ((pref :initarg :pref :accessor change-pref-which)
   (from :initarg :from :accessor change-pref-from)
   (to :initarg :to :accessor change-pref-to))
  (:documentation "A patch for changing a preference."))

(defmethod print-object ((patch change-pref-patch) stream)
  (print-unreadable-object (patch stream :type t)
    (format stream "~A: s/~S/~S/"
            (change-pref-which patch)
            (change-pref-from patch)
            (change-pref-to patch))))

(defclass move-patch (patch)
  ((from :initarg :from :accessor patch-move-from)
   (to :initarg :to :accessor patch-move-to))
  (:documentation "A patch that moves a file."))

(defmethod print-object ((patch move-patch) stream)
  (print-unreadable-object (patch stream :type t)
    (format stream "~A -> ~A"
            (patch-move-from patch)
            (patch-move-to patch))))

;; XXX: this class is probably incorrect and insufficient.
(defclass merger-patch (patch)
  ((version :initarg :version :accessor merger-version)
   (first :initarg :first :accessor merger-first)
   (second :initarg :second :accessor merger-second)
   (inverted :initarg :inverted :accessor merger-inverted)
   (undo :initarg :undo :accessor merger-undo)
   (unwindings :initarg :unwindings :accessor merger-unwindings)))

(defmethod print-object ((patch merger-patch) stream)
  (print-unreadable-object (patch stream :type t)
    (format stream "~:[(inverted) ~;~]~A: ~A ~A"
            (merger-inverted patch)
            (merger-version patch)
            (merger-first patch)
            (merger-second patch))))

;; There are more kinds of patches... let's implement them when need
;; arises.