source: cl-darcs/trunk/record.lisp

;;; Copyright (C) 2006, 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 record-patches (repo name author date log patches)
  "Record PATCHES in REPO.
NAME is the name of the patch, a description of one line.
AUTHOR is the e-mail address (or other identifier) of the author.
DATE is the date in YYYYMMDDHHMMSS format, or the keyword :NOW.
LOG is either NIL or a possibly multi-line description of the patch.
PATCHES is a list of patches that make up the change."
  (let* ((patchinfo
          (make-patchinfo
           :name name :author author
           :date (if (eql date :now)
                     (multiple-value-bind
                           (second minute hour date month year)
                         (get-decoded-time)
                       (format nil "~4,'0d~2,'0d~2,'0d~2,'0d~2,'0d~2,'0d"
                               year month date hour minute second))
                     date)
           :log (when log
                    (split-sequence:split-sequence #\Newline log))))
         (patch (make-instance 'named-patch
                               :patchinfo patchinfo
                               :dependencies nil
                               :patch
                               (make-instance 'composite-patch
                                              :patches patches))))
    (write-patch-to-repo patch repo)
    (apply-patch-to-pristine patch repo)
    (remove-matching-from-pending repo patches)
    (append-inventory repo patchinfo)))

(defun record-changes (repo name author date log)
  "Record changes in REPO.
Arguments as to `record-patches'."
  (let ((patches (diff-repo repo)))
    (flet ((ask (patch)
             (display-patch patch *query-io*)
             (y-or-n-p "Record patch ~A? " patch)))
      (unless patches
        (error "Nothing to record."))

      (record-patches repo name author date log (select-patches patches #'ask)))))

(defun select-patches (patches predicate)
  "Select some of PATCHES using PREDICATE.
Do the necessary commutation and dependency elimination."
  (let (patches-to-record)
    (loop while (setf patches (remove nil patches))
       do
       ;; Should we include this patch? 
       (if (funcall predicate (car patches))
           (progn
             ;; Yes, just add it to the list and go on.
             (push (car patches) patches-to-record)
             (setf patches (cdr patches)))
           ;; No, we need to commute it through the rest of the patches.
           (loop for commute-patches on (cdr patches)
              ;; Try to commute it with the next patch in line.
              do (let ((commute-result (commute (car commute-patches) (car patches))))
                   (if commute-result
                       ;; Commutation succeeded; use the altered patches.
                       (destructuring-bind (commuted-current commuted-future) commute-result
                         (setf (car patches) commuted-current)
                         (setf (car commute-patches) commuted-future))
                       ;; Commutation failed; (car commute-patches) depends on (car patches).
                       ;; Try to commute them together.
                       (progn
                         ;; Turn the patch we are commuting through
                         ;; the list into a composite patch, unless it is
                         ;; one already.  Append the dependency.
                         (etypecase (car patches)
                           (composite-patch
                            (nconc (patches (car patches))
                                   (list (car commute-patches))))
                           (patch
                            (setf (car patches)
                                  (make-instance 'composite-patch
                                                 :patches (list
                                                           (car patches)
                                                           (car commute-patches))))))
                         ;; Drop the dependency from the list of
                         ;; patches to consider.
                         (setf (car commute-patches) nil))))
              finally (setf patches (cdr patches)))))
    (nreverse patches-to-record)))