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. |
---|
41 | Return a list of lists of patchinfo structures. |
---|
42 | |
---|
43 | Note that this function returns patchinfo structures in the order |
---|
44 | they were applied, unlike the real darcs which often uses reverse |
---|
45 | order." |
---|
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. |
---|
91 | Return 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. |
---|
102 | FILE is either nil, meaning the main \"inventory\" file, or a |
---|
103 | string 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. |
---|
164 | OURS and THEIRS are lists of lists of patchinfos, as returned by |
---|
165 | `read-repo-patch-list'. Three values are returned: a list of |
---|
166 | patchinfos that appear in both sets, a list of patchinfos that |
---|
167 | appear only in OURS, and a list of patchinfos that appear only in |
---|
168 | THEIRS." |
---|
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 | |
---|