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 pull (ourrepo &optional theirrepo &key (select-patches :ask)) |
---|
20 | "Pull new patches from THEIRREPO into OURREPO. |
---|
21 | If THEIRREPO is not specified, use default repository specified |
---|
22 | in preferences. |
---|
23 | SELECT-PATCHES specifies how to select which remote patches to pull. |
---|
24 | It can be one of: |
---|
25 | :ALL - pull all patches |
---|
26 | :ASK - ask for each patch through Y-OR-N-P |
---|
27 | a function - call this function with a NAMED-PATCH object, and |
---|
28 | pull if it returns true" |
---|
29 | (setf ourrepo (fad:pathname-as-directory ourrepo)) |
---|
30 | (unless theirrepo |
---|
31 | (setf theirrepo (car (get-preflist ourrepo "defaultrepo"))) |
---|
32 | (unless theirrepo |
---|
33 | (error "No remote repository specified, and no default available."))) |
---|
34 | (add-to-preflist ourrepo "repos" (upath-to-string theirrepo)) |
---|
35 | (let ((motd (get-preflist theirrepo "motd"))) |
---|
36 | (when motd |
---|
37 | (format t "~{~&~A~}" motd))) |
---|
38 | (let ((our-patchinfo (read-repo-patch-list ourrepo)) |
---|
39 | (their-patchinfo (read-repo-patch-list theirrepo))) |
---|
40 | (multiple-value-bind (common only-ours only-theirs) |
---|
41 | (get-common-and-uncommon our-patchinfo their-patchinfo) |
---|
42 | (declare (ignore common)) |
---|
43 | |
---|
44 | (when (null only-theirs) |
---|
45 | (format t "~&No remote changes to pull in.") |
---|
46 | (return-from pull)) |
---|
47 | |
---|
48 | (format t "~&Found these new patches:") |
---|
49 | (dolist (p only-theirs) |
---|
50 | (format t "~& - ~A" p)) |
---|
51 | (let* ((all-their-patches |
---|
52 | (mapcar (lambda (patchinfo) |
---|
53 | (read-patch-from-repo theirrepo patchinfo)) |
---|
54 | only-theirs)) |
---|
55 | (their-patches |
---|
56 | (if (or (eq select-patches :all) |
---|
57 | (and (eq select-patches :ask) |
---|
58 | (y-or-n-p "Pull all patches?"))) |
---|
59 | all-their-patches |
---|
60 | (select-patches all-their-patches |
---|
61 | (if (functionp select-patches) |
---|
62 | select-patches |
---|
63 | (lambda (patch) |
---|
64 | (display-patch patch *query-io*) |
---|
65 | (y-or-n-p "Pull patch ~A? " patch)))))) |
---|
66 | (our-patches |
---|
67 | (mapcar (lambda (patchinfo) |
---|
68 | (read-patch-from-repo ourrepo patchinfo)) |
---|
69 | only-ours)) |
---|
70 | (merged-patches (patches |
---|
71 | (merge-patches (make-instance 'composite-patch |
---|
72 | :patches their-patches) |
---|
73 | (make-instance 'composite-patch |
---|
74 | :patches our-patches))))) |
---|
75 | (format t "~&Applying patches") |
---|
76 | (let ((applying-to-source t) |
---|
77 | (source-and-pristine-differ nil)) |
---|
78 | (dolist (p merged-patches) |
---|
79 | ;; First, copy the modified patch to the repository. |
---|
80 | (write-patch-to-repo p ourrepo) |
---|
81 | ;; Then, apply it to the pristine copy. This couldn't |
---|
82 | ;; possibly fail. |
---|
83 | (apply-patch-to-pristine p ourrepo) |
---|
84 | ;; Note the patch in the inventory. |
---|
85 | (append-inventory ourrepo (named-patch-patchinfo p)) |
---|
86 | ;; And finally apply the patch to the real source. This |
---|
87 | ;; could fail if the source has been modified. Deal with |
---|
88 | ;; that in a crude way. XXX: it is wasteful to apply |
---|
89 | ;; patches twice. |
---|
90 | (when applying-to-source |
---|
91 | (restart-case |
---|
92 | (apply-patch p ourrepo) |
---|
93 | (skip-this () |
---|
94 | :report "Don't apply this patch to the source tree (it was applied to the pristine tree)" |
---|
95 | (setf source-and-pristine-differ t)) |
---|
96 | (skip-all () |
---|
97 | :report "Stop trying to apply patches to the source tree (they will be applied to the pristine tree)" |
---|
98 | (setf source-and-pristine-differ t) |
---|
99 | (setf applying-to-source nil)))) |
---|
100 | (princ #\.) |
---|
101 | (force-output)) |
---|
102 | (when source-and-pristine-differ |
---|
103 | (format t "~&~<Some patches could not be applied to the source tree. ~ |
---|
104 | You should manually merge changes from the pristine tree in _darcs/pristine/.~>" nil))))) |
---|
105 | (format t "~&Finished pulling and applying."))) |
---|