source: cl-darcs/trunk/pending.lisp

Last change on this file was 160, checked in by Magnus Henoch, 14 years ago

When adding a file, make sure that we can read it

File size: 4.5 KB
Line 
1;;; Copyright (C) 2007, 2008 Magnus Henoch
2;;;
3;;; This program is free software; you can redistribute it and/or
4;;; modify it under the terms of the GNU General Public License as
5;;; published by the Free Software Foundation; either version 2 of the
6;;; License, or (at your option) any later version.
7;;;
8;;; This program is distributed in the hope that it will be useful,
9;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11;;; General Public License for more details.
12;;;
13;;; You should have received a copy of the GNU General Public License
14;;; along with this program; if not, write to the Free Software
15;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
16
17(in-package :darcs)
18
19(defun pending-filename (repodir)
20  "Get the name of the file containing \"pending\" patches for REPODIR."
21  (upath-subdir repodir '("_darcs" "patches") "pending"))
22
23(defun read-pending (repodir)
24  "Read the \"pending\" patches of REPODIR."
25  (let ((pending-file (pending-filename repodir)))
26    (when (probe-file pending-file)
27      (read-patch-from-file pending-file :compressed nil))))
28
29(defun write-pending (repodir patch)
30  "Write PATCH to the \"pending\" file in REPODIR.
31The previous file is overwritten."
32  (declare (type (or null composite-patch) patch))
33  (if (and patch (patches patch))
34      (with-open-file (out (pending-filename repodir)
35                           :direction :output :element-type '(unsigned-byte 8)
36                           :if-exists :supersede)
37        (write-patch patch out))
38      (delete-file (pending-filename repodir))))
39
40(defun add-to-pending (repodir patch)
41  "Add PATCH to the list of \"pending\" patches in REPODIR."
42  (let ((pending (read-pending repodir)))
43    (when (null pending)
44      (setf pending (make-instance 'composite-patch)))
45    (setf (patches pending) (append (patches pending) (list patch)))
46    (write-pending repodir pending)))
47
48(defun remove-matching-from-pending (repodir patches)
49  "Remove PATCHES from the list of \"pending\" patches in REPODIR."
50  ;; Currently we only have ADD-FILE-PATCH and ADD-DIR-PATCH in
51  ;; pending, which can be compared by EQUAL-PATCH.
52  (let ((pending (read-pending repodir)))
53    (when pending
54      (setf (patches pending)
55            (nset-difference (patches pending) patches :test #'equal-patch))
56      (write-pending repodir pending))))
57
58(defun add-file (repo file)
59  "Schedule FILE for recording to REPO.
60FILE can be a string or a pathname denoting a relative path.
61FILE can be either a file or a directory."
62  (setf repo (fad:pathname-as-directory repo))
63  (setf file (enough-namestring file repo))
64  (let ((type
65         (if (fad:directory-exists-p 
66              (fad:pathname-as-directory (merge-pathnames file repo)))
67             :directory 
68             :file)))
69    (setf file (sanitize-filename file :type type))
70
71    (let ((pristine-file (merge-pathnames file (upath-subdir repo '("_darcs" "pristine"))))
72          (working-file (merge-pathnames file repo)))
73      ;; Make sure that we can read the file
74      (when (eql type :file)
75        (with-open-file (s working-file :direction :input)
76          t))
77
78      ;; XXX: does this work properly for directories?
79      (when (or
80             ;; Is file/directory already committed?
81             (if (eql type :file)
82                 (fad:file-exists-p pristine-file)
83                 (fad:directory-exists-p pristine-file))
84             ;; Or is it already added to pending?
85             (let* ((pending (read-pending repo))
86                    (patches (when pending (patches pending))))
87               (or
88                (find file patches 
89                      :key (lambda (p) (when (typep p 'add-file-patch) (patch-filename p)))
90                      :test #'equal)
91                (find file patches
92                      :key (lambda (p) (when (typep p 'add-dir-patch) (patch-directory p)))
93                      :test #'equal))))
94        (error 'already-in-repository :repository repo :file file))
95      (when (not (if (eql type :file)
96                     (fad:file-exists-p working-file)
97                     (fad:directory-exists-p working-file)))
98        (error "~A does not exist in the working directory." (pathname-to-string file))))
99    ;; XXX: check that all parent directories exist, either in pristine or in pending
100
101    (add-to-pending
102     repo 
103     (if (eql type :file)
104         (make-instance 'add-file-patch :filename file)
105         (make-instance 'add-dir-patch :directory file)))))
106
107(define-condition already-in-repository (repository-file-condition error)
108  ()
109  (:documentation "The file to be added already exists in the repository.")
110  (:report (lambda (condition stream)
111             (format stream
112                     "~A already exists in the repository in ~A."
113                     (slot-value condition 'file)
114                     (slot-value condition 'repository)))))
Note: See TracBrowser for help on using the repository browser.