source: cl-darcs/tags/0.1.0/repo.lisp

Last change on this file was 35, checked in by Magnus Henoch, 16 years ago

Enable specifying which patches to get in get-repo, at the cost of not
writing tag-based inventories.

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