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

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

Add functions for keeping a pristine. Use it when getting and pulling.

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