source: cl-darcs/trunk/pending.lisp

;;; Copyright (C) 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 pending-filename (repodir)
  "Get the name of the file containing \"pending\" patches for REPODIR."
  (upath-subdir repodir '("_darcs" "patches") "pending"))

(defun read-pending (repodir)
  "Read the \"pending\" patches of REPODIR."
  (let ((pending-file (pending-filename repodir)))
    (when (probe-file pending-file)
      (read-patch-from-file pending-file :compressed nil))))

(defun write-pending (repodir patch)
  "Write PATCH to the \"pending\" file in REPODIR.
The previous file is overwritten."
  (declare (type (or null composite-patch) patch))
  (if (and patch (patches patch))
      (with-open-file (out (pending-filename repodir)
                           :direction :output :element-type '(unsigned-byte 8)
                           :if-exists :supersede)
        (write-patch patch out))
      (delete-file (pending-filename repodir))))

(defun add-to-pending (repodir patch)
  "Add PATCH to the list of \"pending\" patches in REPODIR."
  (let ((pending (read-pending repodir)))
    (when (null pending)
      (setf pending (make-instance 'composite-patch)))
    (setf (patches pending) (append (patches pending) (list patch)))
    (write-pending repodir pending)))

(defun remove-matching-from-pending (repodir patches)
  "Remove PATCHES from the list of \"pending\" patches in REPODIR."
  ;; Currently we only have ADD-FILE-PATCH and ADD-DIR-PATCH in
  ;; pending, which can be compared by EQUAL-PATCH.
  (let ((pending (read-pending repodir)))
    (when pending
      (setf (patches pending)
            (nset-difference (patches pending) patches :test #'equal-patch))
      (write-pending repodir pending))))

(defun add-file (repo file)
  "Schedule FILE for recording to REPO.
FILE can be a string or a pathname denoting a relative path.
FILE can be either a file or a directory."
  (setf repo (fad:pathname-as-directory repo))
  (setf file (enough-namestring file repo))
  (let ((type
         (if (fad:directory-exists-p 
              (fad:pathname-as-directory (merge-pathnames file repo)))
             :directory 
             :file)))
    (setf file (sanitize-filename file :type type))

    (let ((pristine-file (merge-pathnames file (upath-subdir repo '("_darcs" "pristine"))))
          (working-file (merge-pathnames file repo)))
      ;; Make sure that we can read the file
      (when (eql type :file)
        (with-open-file (s working-file :direction :input)
          t))

      ;; XXX: does this work properly for directories?
      (when (or
             ;; Is file/directory already committed?
             (if (eql type :file)
                 (fad:file-exists-p pristine-file)
                 (fad:directory-exists-p pristine-file))
             ;; Or is it already added to pending?
             (let* ((pending (read-pending repo))
                    (patches (when pending (patches pending))))
               (or
                (find file patches 
                      :key (lambda (p) (when (typep p 'add-file-patch) (patch-filename p)))
                      :test #'equal)
                (find file patches
                      :key (lambda (p) (when (typep p 'add-dir-patch) (patch-directory p)))
                      :test #'equal))))
        (error 'already-in-repository :repository repo :file file))
      (when (not (if (eql type :file)
                     (fad:file-exists-p working-file)
                     (fad:directory-exists-p working-file)))
        (error "~A does not exist in the working directory." (pathname-to-string file))))
    ;; XXX: check that all parent directories exist, either in pristine or in pending

    (add-to-pending
     repo 
     (if (eql type :file)
         (make-instance 'add-file-patch :filename file)
         (make-instance 'add-dir-patch :directory file)))))

(define-condition already-in-repository (repository-file-condition error)
  ()
  (:documentation "The file to be added already exists in the repository.")
  (:report (lambda (condition stream)
             (format stream
                     "~A already exists in the repository in ~A."
                     (slot-value condition 'file)
                     (slot-value condition 'repository)))))