source: cl-darcs/trunk/repo.lisp

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

Add test suite

File size: 7.1 KB
Line 
1;;; Copyright (C) 2006, 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 prepare-new-repo (outname)
20  "Create directories for starting a repo at OUTNAME."
21  (unless (fad:directory-exists-p outname)
22    (error "Directory ~A does not exist." outname))
23  (let ((darcs-dir (merge-pathnames
24                    (make-pathname :directory (list :relative "_darcs"))
25                    outname)))
26    (when (fad:directory-exists-p darcs-dir)
27      ;; This error message should match the one in darcs/tests/init.pl
28      (error "Do not run this command in a repository."))
29    (make-dir darcs-dir)
30    (dolist (dir '("patches" "checkpoints" "prefs" "inventories"))
31      (make-dir (merge-pathnames
32                 (make-pathname :directory (list :relative dir))
33                 darcs-dir)))
34    (write-inventory outname ()))
35  (write-default-prefs outname))
36
37;; {lazily,}read_repo in DarcsRepo.lhs
38;; read_repo_private in DarcsRepo.lhs
39(defun read-repo-patch-list (inrepodir &optional inventory-file)
40  "Read patch info for INREPODIR from INVENTORY-FILE.
41Return a list of lists of patchinfo structures.
42
43Note that this function returns patchinfo structures in the order
44they were applied, unlike the real darcs which often uses reverse
45order."
46  (when (null inventory-file)
47    (setf inventory-file (upath-subdir inrepodir '("_darcs") "inventory")))
48  (let (tag-patches patches)
49    (with-open-stream (in (make-instance 'unreadable-stream
50                                         :base-stream (open-upath inventory-file :binary t)))
51      (let ((first-line (read-binary-line in nil :eof)))
52        (when (eq first-line :eof)
53          ;; XXX: should this be (list nil)?
54          (return-from read-repo-patch-list nil))
55        ;; If first line is "Starting with tag:",
56        (if (string= (bytes-to-string first-line) "Starting with tag:")
57            (let* ((tag-patch
58                    ;; read the first patch...
59                    (read-patchinfo in))
60                   (new-filename (patchinfo-make-filename tag-patch)))
61              ;; ...for the first patch is a tag.  Recursively read
62              ;; the inventory of that file.  The tag patch then goes
63              ;; at the head of the current list of patches.
64              (setf tag-patches
65                    (read-repo-patch-list
66                     inrepodir (upath-subdir inrepodir '("_darcs" "inventories") new-filename)))
67              (setf patches (list tag-patch)))
68            ;; If it's not, pretend we never read that line.
69            (unread-line in first-line)))
70      ;; Then, just read all patches in the file.
71      (format t "~&Reading patchinfo from ~A" inventory-file)
72      (setf patches
73            (nconc patches
74                   (loop for patch = (read-patchinfo in)
75                      while patch collect patch
76                      do (princ #\.)))))
77    (cons patches tag-patches)))
78
79(defun read-patch-from-repo (repodir patchinfo)
80  "Read patch named by PATCHINFO from REPODIR."
81  (read-patch-from-file
82   (upath-subdir repodir '("_darcs" "patches") (patchinfo-make-filename patchinfo))))
83
84(defun read-checkpoint-from-repo (repodir patchinfo)
85  "Read checkpoint named by PATCHINFO from REPODIR."
86  (read-patch-from-file
87   (upath-subdir repodir '("_darcs" "checkpoints") (patchinfo-make-filename patchinfo))))
88
89(defun read-checkpoint-list (repodir)
90  "Read a list of checkpoints from REPODIR.
91Return as a patchinfo list."
92  ;; If there are no checkpoints, it doesn't matter.
93  (ignore-errors
94    (with-open-stream (in (open-upath (upath-subdir repodir '("_darcs" "checkpoints") "inventory")))
95      (format t "~&Reading checkpoints")
96      (loop for patch = (read-patchinfo in)
97         while patch collect patch
98         do (princ #\.)))))
99
100(defun write-inventory (out patchinfo-list &optional file)
101  "Write PATCHINFO-LIST as inventory in OUT.
102FILE is either nil, meaning the main \"inventory\" file, or a
103string naming a file in the \"inventories\" directory."
104  ;; XXX: slightly_optimize_patchset?
105  (let ((inventory-file (cond
106                          ((null file)
107                           (merge-pathnames
108                            (make-pathname :directory '(:relative "_darcs")
109                                           :name "inventory")
110                            out))
111                          (t
112                           (merge-pathnames
113                            (make-pathname :directory '(:relative "_darcs" "inventories")
114                                           :name file)
115                            out)))))
116    (with-open-file (f inventory-file :direction :output :if-exists :supersede
117                       :element-type '(unsigned-byte 8))
118      (flet ((print-patchinfos (patchinfos)
119               ;; Convert output to binary, using the most direct possible
120               ;; method...
121               (dolist (patchinfo patchinfos)
122                 (map nil (lambda (char)
123                            (write-byte (char-code char) f))
124                      (with-output-to-string (strout)
125                        (write-patchinfo patchinfo strout)))
126                 (write-byte 10 f))))
127        (cond
128          ((null patchinfo-list)
129           ;; No patches - empty inventory file.  Nothing to do.
130           )
131          ((null (cdr patchinfo-list))
132           ;; One patch list - no remaining tags.
133
134           (print-patchinfos (car patchinfo-list)))
135          (t
136           ;; Several patch lists, one for each tag
137           (let* ((this-tag (car patchinfo-list))
138                  (other-tags (cdr patchinfo-list))
139                  (tag-name (patchinfo-make-filename (car this-tag))))
140             (write-inventory out other-tags tag-name)
141             (write-sequence (map 'vector #'char-code "Starting with tag:") f)
142             (write-byte 10 f)
143             (print-patchinfos (car patchinfo-list)))))))))
144
145(defun append-inventory (outrepo patchinfo)
146  "Append PATCHINFO to inventory in OUTREPO."
147  (with-open-file (f (merge-pathnames 
148                      (make-pathname :directory '(:relative "_darcs")
149                                     :name "inventory")
150                      outrepo)
151                     :direction :output
152                     :if-exists :append
153                     :if-does-not-exist :create
154                     :element-type '(unsigned-byte 8))
155    (map nil (lambda (char)
156               (write-byte (char-code char) f))
157         (with-output-to-string (strout)
158           (write-patchinfo patchinfo strout)))
159    (write-byte 10 f)))
160
161;; See also tests/gcau-tests.lisp
162(defun get-common-and-uncommon (ours theirs)
163  "Given patchsets OURS and THEIRS, find common and uncommon patches.
164OURS and THEIRS are lists of lists of patchinfos, as returned by
165`read-repo-patch-list'.  Three values are returned: a list of
166patchinfos that appear in both sets, a list of patchinfos that
167appear only in OURS, and a list of patchinfos that appear only in
168THEIRS."
169  ;; Of course, there are possible optimizations here, in particular
170  ;; regarding tags, but this will do for now.
171  (setf ours (apply #'append (reverse ours)))
172  (setf theirs (apply #'append (reverse theirs)))
173  (let (common-patches our-patches their-patches)
174    (loop
175       for ou on ours and th on theirs
176       while (equalp (car ou) (car th))
177       collect (car ou) into common
178       finally
179         (setf common-patches common
180               our-patches ou
181               their-patches th))
182    (values common-patches our-patches their-patches)))
183
Note: See TracBrowser for help on using the repository browser.