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 create-repo (repodir) |
---|
20 | "Create an empty repository." |
---|
21 | (setf repodir (fad:pathname-as-directory repodir)) |
---|
22 | |
---|
23 | ;; Create the directory if it doesn't exist, then get the absolute |
---|
24 | ;; path. |
---|
25 | (ensure-directories-exist repodir) |
---|
26 | (setf repodir (truename repodir)) |
---|
27 | |
---|
28 | ;; Darcsify it. |
---|
29 | (prepare-new-repo repodir) |
---|
30 | (create-empty-pristine repodir)) |
---|
31 | |
---|
32 | ;; get_cmd in Get.lhs |
---|
33 | (defun get-repo (inrepodir outname &key (partial nil) (query nil)) |
---|
34 | (setf outname (fad:pathname-as-directory outname)) |
---|
35 | ;; other access methods later... |
---|
36 | ;; XXX: checkpoints? |
---|
37 | (let* ((repodir (make-upath inrepodir :truename t)) |
---|
38 | ;; Here we get a list of lists. Each list represents a tag; |
---|
39 | ;; the latest tag is at the head. Each list contains patches |
---|
40 | ;; in the order they are to be applied. |
---|
41 | (patchinfo-list (read-repo-patch-list repodir)) |
---|
42 | ;; We should probably download checkpoint patches, btw... |
---|
43 | (checkpoint (when partial |
---|
44 | (car (last (read-checkpoint-list repodir)))))) |
---|
45 | (let ((motd (get-preflist repodir "motd"))) |
---|
46 | (when motd |
---|
47 | (format t "~{~&~A~}" motd))) |
---|
48 | |
---|
49 | ;; Create directories... |
---|
50 | (ensure-directories-exist outname) |
---|
51 | ;; Now that the directory exists, we can get its truename |
---|
52 | (setf outname (truename outname)) |
---|
53 | (prepare-new-repo outname) |
---|
54 | (set-default-repo outname (upath-to-string inrepodir :truename t)) |
---|
55 | |
---|
56 | (when checkpoint |
---|
57 | (format t "~&Copying checkpoint...") |
---|
58 | (copy-checkpoint repodir outname checkpoint) |
---|
59 | ;; After copying, we can read the checkpoint from OUTNAME. |
---|
60 | (let ((checkpoint-patch (read-checkpoint-from-repo outname checkpoint))) |
---|
61 | (apply-patch checkpoint-patch outname)) |
---|
62 | (format t "done")) |
---|
63 | |
---|
64 | |
---|
65 | (let* ((all-patches (if checkpoint |
---|
66 | ;; XXX: patchinfo-list is a list of lists now |
---|
67 | (find-remaining-patches patchinfo-list checkpoint) |
---|
68 | (apply #'append (reverse patchinfo-list)))) |
---|
69 | (patches |
---|
70 | (if (or (null query) (y-or-n-p "Apply all patches?")) |
---|
71 | all-patches |
---|
72 | (select-some-patches all-patches)))) |
---|
73 | ;; write-inventory wants patches ordered by tags, but we have |
---|
74 | ;;them all in a list in all-patches and patches... |
---|
75 | ;;(write-inventory outname patchinfo-list) |
---|
76 | (copy-repo-patches repodir outname patches) |
---|
77 | |
---|
78 | (format t "~&Applying patches") |
---|
79 | (dolist (patchinfo patches) |
---|
80 | (let ((patch (read-patch-from-repo outname patchinfo))) |
---|
81 | (apply-patch patch outname) |
---|
82 | ;; XXX: this is where we write tags to inventory correctly |
---|
83 | ;; Check how darcs handles tags - rotate inventory files? |
---|
84 | ;; What happens when adding patches one by one? |
---|
85 | (append-inventory outname patchinfo) |
---|
86 | (princ #\.) |
---|
87 | (force-output))) |
---|
88 | (format t "~&Creating pristine") |
---|
89 | (create-pristine-from-tree outname) |
---|
90 | (format t "~&Finished getting.")))) |
---|
91 | |
---|
92 | (defun select-some-patches (patchinfo-list) |
---|
93 | "Interactively select some patches from PATCHINFO-LIST. |
---|
94 | Return a new list containing the selected patches." |
---|
95 | (format t "~&Available patches:") |
---|
96 | (loop for patchinfo in patchinfo-list |
---|
97 | count patchinfo into i |
---|
98 | do (format t "~&~3@A ~A" i patchinfo)) |
---|
99 | (format t "~&Specify inclusive start and end (NIL will do): ") |
---|
100 | (let ((start (read)) (end (read))) |
---|
101 | (if start |
---|
102 | (decf start) |
---|
103 | (setf start 0)) |
---|
104 | (subseq patchinfo-list start end))) |
---|
105 | |
---|
106 | (defun find-remaining-patches (patchinfo-list checkpoint) |
---|
107 | "Find the patches remaining after getting to CHECKPOINT." |
---|
108 | ;; XXX: this is incorrect; the checkpoint isn't among ordinary patches. |
---|
109 | (loop for tail on patchinfo-list |
---|
110 | when (equalp (car tail) checkpoint) |
---|
111 | return (cdr tail))) |
---|
112 | |
---|
113 | (defun copy-repo-patches (from to patchinfo-list) |
---|
114 | "Copy patches from repository FROM to repository TO. |
---|
115 | PATCHINFO-LIST is the list of patches in FROM to copy." |
---|
116 | (format t "~&Copying ~A patches" (length patchinfo-list)) |
---|
117 | ;; Assume that TO/_darcs/patches is created |
---|
118 | (dolist (patch patchinfo-list) |
---|
119 | (let ((filename (patchinfo-make-filename patch))) |
---|
120 | (with-open-file (out (merge-pathnames |
---|
121 | (make-pathname :directory (list :relative "_darcs" "patches") |
---|
122 | :name filename) |
---|
123 | to) |
---|
124 | :direction :output :element-type '(unsigned-byte 8)) |
---|
125 | (with-open-stream (in (open-upath |
---|
126 | (upath-subdir from '("_darcs" "patches") filename) |
---|
127 | :binary t)) |
---|
128 | (fad:copy-stream in out)))) |
---|
129 | (princ #\.) |
---|
130 | (force-output))) |
---|
131 | |
---|
132 | (defun copy-checkpoint (from to checkpoint) |
---|
133 | "Copy CHECKPOINT from repository FROM to repository TO. |
---|
134 | CHECKPOINT is a patchinfo naming the checkpoint." |
---|
135 | (let ((filename (patchinfo-make-filename checkpoint))) |
---|
136 | (with-open-file (out (merge-pathnames |
---|
137 | (make-pathname :directory '(:relative "_darcs" "checkpoints") |
---|
138 | :name filename) |
---|
139 | to) |
---|
140 | :direction :output :element-type '(unsigned-byte 8)) |
---|
141 | (with-open-stream (in (open-upath |
---|
142 | (upath-subdir from '("_darcs" "checkpoints") filename) |
---|
143 | :binary t)) |
---|
144 | (fad:copy-stream in out))))) |
---|
145 | |
---|