1 | ;;; Copyright (C) 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 | (defvar *darcs-commands* () |
---|
20 | "List of commands that can be executed from the command line. |
---|
21 | Each element is a symbol that names the command. The corresponding |
---|
22 | function is named cmd-SYMBOL, and is called with all command line |
---|
23 | arguments but the first one. It should return an integer exit code.") |
---|
24 | |
---|
25 | (eval-when (:compile-toplevel :load-toplevel) |
---|
26 | (defun command-function (command) |
---|
27 | "Turn a command symbol into a function symbol." |
---|
28 | (intern (format nil "CMD-~A" command) :darcs))) |
---|
29 | |
---|
30 | (defun handle-command-line (argv) |
---|
31 | "Handle a command line, emulating the real darcs client. |
---|
32 | ARGV is a list of strings. This function is to be called in some |
---|
33 | platform-dependent manner, while being portable itself. An integer |
---|
34 | exit code is returned." |
---|
35 | (let* ((command (find (car argv) *darcs-commands* :test #'string-equal)) |
---|
36 | (function (when command (command-function command)))) |
---|
37 | (if (null command) |
---|
38 | (progn |
---|
39 | (if (null argv) |
---|
40 | (format *error-output* "No command given!~%") |
---|
41 | (format *error-output* "Invalid command '~A'!~%" (car argv))) |
---|
42 | (usage) |
---|
43 | 1) |
---|
44 | (handler-case |
---|
45 | (let ((retval (funcall function (cdr argv)))) |
---|
46 | (fresh-line) |
---|
47 | (if (numberp retval) |
---|
48 | retval |
---|
49 | (progn |
---|
50 | (warn "~A didn't give a proper exit code." command) |
---|
51 | 0))) |
---|
52 | (invalid-arguments (c) |
---|
53 | (with-accessors ((ctrl simple-condition-format-control) |
---|
54 | (args simple-condition-format-arguments)) c |
---|
55 | (when ctrl |
---|
56 | (apply #'format *error-output* ctrl args))) |
---|
57 | (command-usage command) |
---|
58 | 1))))) |
---|
59 | |
---|
60 | (defun usage () |
---|
61 | "Print usage information about commands to *ERROR-OUTPUT*." |
---|
62 | (format *error-output* "Usage: darcs COMMAND ...~%~%Commands:~%") |
---|
63 | (dolist (cmd *darcs-commands*) |
---|
64 | (let ((function (command-function cmd))) |
---|
65 | (format *error-output* " ~A~15,2T~A~%" |
---|
66 | cmd |
---|
67 | (car (split-sequence:split-sequence |
---|
68 | #\Newline (get function 'darcs-documentation) |
---|
69 | :count 1)))))) |
---|
70 | |
---|
71 | (defun command-usage (command) |
---|
72 | "Print longer documentation for COMMAND." |
---|
73 | (format *error-output* "~&~A~%" (get (command-function command) 'darcs-documentation))) |
---|
74 | |
---|
75 | (defmacro define-darcs-command (name options operands docstring &body body) |
---|
76 | "Define a darcs command called NAME. |
---|
77 | NAME is passed to COMMAND-FUNCTION to make the name of the function. |
---|
78 | OPTIONS is a list of variables holding OPTION structures, describing |
---|
79 | the options accepted by the commnad. |
---|
80 | OPERANDS is a destructuring lambda list for the non-option arguments |
---|
81 | accepted by the command." |
---|
82 | (flet ((option-symbol (name) |
---|
83 | (intern (concatenate 'string "OPT-" (symbol-name name))))) |
---|
84 | (let ((function (command-function name)) |
---|
85 | (args-sym (gensym)) |
---|
86 | (options-sym (gensym)) |
---|
87 | (operands-sym (gensym))) |
---|
88 | `(progn |
---|
89 | (pushnew ',name *darcs-commands*) |
---|
90 | (defun ,function (,args-sym) ,docstring |
---|
91 | (multiple-value-bind (,options-sym ,operands-sym) |
---|
92 | (getopt ,args-sym |
---|
93 | (list ,@(mapcar #'option-symbol options))) |
---|
94 | ,@(when (null options) |
---|
95 | `((declare (ignore ,options-sym)))) |
---|
96 | (let ,(mapcar |
---|
97 | (lambda (o) |
---|
98 | `(,o (cdr (assoc (option-keyword ,(option-symbol o)) ,options-sym)))) |
---|
99 | options) |
---|
100 | ;; XXX: what if this fails? |
---|
101 | (destructuring-bind ,operands ,operands-sym |
---|
102 | ,@body)))) |
---|
103 | (setf (get ',function 'darcs-documentation) |
---|
104 | ;; XXX: documentation for operands |
---|
105 | ,(if (null options) |
---|
106 | docstring |
---|
107 | `(format nil |
---|
108 | "~A~%~%~:{~A~30,5T~A~%~}" |
---|
109 | ,docstring |
---|
110 | (mapcar |
---|
111 | (lambda (opt) |
---|
112 | (list |
---|
113 | (cond |
---|
114 | ((and (option-short opt) |
---|
115 | (option-long opt)) |
---|
116 | (format nil "--~A~@[=~A~], -~C" |
---|
117 | (option-long opt) |
---|
118 | (option-arg opt) |
---|
119 | (option-short opt))) |
---|
120 | ((option-short opt) |
---|
121 | (format nil "-~C~@[ ~A~]" |
---|
122 | (option-short opt) |
---|
123 | (option-arg opt))) |
---|
124 | ((option-long opt) |
---|
125 | (format nil "--~A~@[=~A~]" |
---|
126 | (option-long opt) |
---|
127 | (option-arg opt))) |
---|
128 | (t |
---|
129 | (error "Option ~A has neither short nor long argument form." (option-keyword opt)))) |
---|
130 | (option-help opt))) |
---|
131 | (list ,@(mapcar #'option-symbol options)))))))))) |
---|
132 | |
---|
133 | (defparameter opt-repodir |
---|
134 | (make-option |
---|
135 | :keyword :repodir |
---|
136 | :long "repodir" |
---|
137 | :arg "DIRECTORY" |
---|
138 | :help "Use DIRECTORY instead of current directory")) |
---|
139 | |
---|
140 | (defun find-repo (&optional (dir *default-pathname-defaults*)) |
---|
141 | "Find repository in current directory or above. |
---|
142 | Signal an error if there is none, else return the repository root. |
---|
143 | If DIR is specified, search for repository there instead." |
---|
144 | (if (fad:directory-exists-p (upath-subdir dir '("_darcs"))) |
---|
145 | (fad:directory-exists-p dir) ;get directory truename |
---|
146 | (let ((parent-dir (ignore-errors |
---|
147 | (fad:directory-exists-p |
---|
148 | (merge-pathnames |
---|
149 | (make-pathname :directory '(:relative :up)) |
---|
150 | dir))))) |
---|
151 | (if (and parent-dir (not (equal dir parent-dir))) |
---|
152 | (find-repo parent-dir) |
---|
153 | (error "Not in a darcs repo."))))) |
---|
154 | |
---|
155 | (defmacro with-repo (repodir &body body) |
---|
156 | "Given a --repodir argument, canonicalize it and change directory accordingly. |
---|
157 | That is, if there is no --repodir option, don't change current directory, |
---|
158 | and bind variable to the repository root directory. |
---|
159 | If there is a --repodir option, ensure it refers to an existing directory, |
---|
160 | and change the current directory to it. |
---|
161 | \(This is actually how the original darcs does it.\)" |
---|
162 | (let ((original-repodir (gensym))) |
---|
163 | `(let* ((,original-repodir ,repodir) |
---|
164 | (,repodir |
---|
165 | (if ,repodir |
---|
166 | (or (fad:directory-exists-p ,repodir) |
---|
167 | (error "Directory ~A does not exist." ,repodir)) |
---|
168 | (find-repo))) |
---|
169 | ;; If explicit --repodir argument was specified, change directory. |
---|
170 | ;; Otherwise, leave it, even if the actual repository is in a |
---|
171 | ;; parent directory. |
---|
172 | (*default-pathname-defaults* |
---|
173 | (if (null ,original-repodir) |
---|
174 | *default-pathname-defaults* |
---|
175 | (fad:pathname-as-directory ,repodir)))) |
---|
176 | ,@body))) |
---|
177 | |
---|
178 | (define-darcs-command add (repodir) (&rest files-and-dirs |
---|
179 | &aux already-there) |
---|
180 | "Add files and directories for later recording. |
---|
181 | |
---|
182 | Usage: darcs add FILE ..." |
---|
183 | (with-repo repodir |
---|
184 | (dolist (file files-and-dirs) |
---|
185 | (handler-case |
---|
186 | (progn |
---|
187 | (add-file repodir file) |
---|
188 | ;; (format t "~&Added ~A" file) |
---|
189 | ) |
---|
190 | (already-in-repository (c) |
---|
191 | ;; Save the files and directories that are already in the |
---|
192 | ;; repository for pretty error printing. |
---|
193 | (push (slot-value c 'file) already-there)))) |
---|
194 | (when already-there |
---|
195 | (setf already-there (nreverse already-there)) |
---|
196 | (let* ((with-path (mapcar (lambda (f) (merge-pathnames f repodir)) already-there)) |
---|
197 | (nfiles 0) |
---|
198 | (ndirs 0)) |
---|
199 | (dolist (f with-path) |
---|
200 | (let ((truename (fad:file-exists-p f))) |
---|
201 | (assert truename) |
---|
202 | (if (fad:directory-pathname-p f) |
---|
203 | (incf ndirs) |
---|
204 | (incf nfiles)))) |
---|
205 | (assert (= (+ nfiles ndirs) (length already-there))) |
---|
206 | ;; We want the message to look just like darcs', in order to |
---|
207 | ;; pass its test suite (in particular tests/add.pl). |
---|
208 | (format *error-output* |
---|
209 | "~&The following ~A already in the repository" |
---|
210 | (cond |
---|
211 | ((zerop nfiles) |
---|
212 | (if (= ndirs 1) |
---|
213 | "directory is" |
---|
214 | "directories are")) |
---|
215 | ((zerop ndirs) |
---|
216 | (if (= nfiles 1) |
---|
217 | "file is" |
---|
218 | "files are")) |
---|
219 | (t |
---|
220 | "files and directories are"))) |
---|
221 | (format *error-output* ":~%~{ ~A~}" already-there)))) |
---|
222 | 0) |
---|
223 | |
---|
224 | (define-darcs-command whatsnew () () |
---|
225 | "See what has been changed in the working directory. |
---|
226 | |
---|
227 | Usage: darcs whatsnew" |
---|
228 | (diff-repo-display (find-repo))) |
---|
229 | |
---|
230 | (define-darcs-command init (repodir) () |
---|
231 | "Initialize a darcs repository in the current directory." |
---|
232 | (let ((repodir (or repodir |
---|
233 | *default-pathname-defaults*))) |
---|
234 | (format t "Creating repo in ~A...~%" repodir) |
---|
235 | (create-repo repodir) |
---|
236 | 0)) |
---|
237 | |
---|
238 | (defparameter opt-author |
---|
239 | (make-option |
---|
240 | :keyword :author |
---|
241 | :short #\A |
---|
242 | :long "author" |
---|
243 | :arg "EMAIL" |
---|
244 | :help "specify author id")) |
---|
245 | |
---|
246 | (defparameter opt-all-patches |
---|
247 | (make-option |
---|
248 | :keyword :all-patches |
---|
249 | :short #\a |
---|
250 | :long "all" |
---|
251 | :help "answer yes to all patches")) |
---|
252 | |
---|
253 | (defparameter opt-patch-name |
---|
254 | (make-option |
---|
255 | :keyword :patch-name |
---|
256 | :short #\m |
---|
257 | :long "patch-name" |
---|
258 | :arg "PATCHNAME" |
---|
259 | :help "name of patch")) |
---|
260 | |
---|
261 | (defparameter opt-ask-deps |
---|
262 | (make-option |
---|
263 | :keyword :ask-deps |
---|
264 | :long "ask-deps" |
---|
265 | :help "ask for extra dependencies")) |
---|
266 | |
---|
267 | (define-darcs-command record |
---|
268 | (author all-patches patch-name ask-deps repodir) |
---|
269 | (&rest files) |
---|
270 | "Save changes in the working copy to the repository as a patch." |
---|
271 | (with-repo repodir |
---|
272 | (let* ((author (or author |
---|
273 | ;; XXX: other ways to indicate author |
---|
274 | (progn |
---|
275 | (format *query-io* "~&Who is the author? ") |
---|
276 | (finish-output *query-io*) |
---|
277 | (read-line *query-io*)))) |
---|
278 | (patch-name (or patch-name |
---|
279 | (progn |
---|
280 | (format *query-io* "~&What is the patch name? ") |
---|
281 | (finish-output *query-io*) |
---|
282 | (read-line *query-io*)))) |
---|
283 | (files (mapcar |
---|
284 | (lambda (file) |
---|
285 | (setf file (enough-namestring file repodir)) |
---|
286 | (if (fad:directory-exists-p file) |
---|
287 | (sanitize-filename file :type :directory) |
---|
288 | (sanitize-filename file :type :file))) |
---|
289 | files))) |
---|
290 | ;; XXX: long log |
---|
291 | |
---|
292 | (let ((patches (diff-repo repodir))) |
---|
293 | (flet ((ask (patch) |
---|
294 | ;; If any files were specified, use only patches |
---|
295 | ;; touching those files/directories. |
---|
296 | (if (or (null files) |
---|
297 | (and (typep patch 'file-patch) |
---|
298 | (member (patch-filename patch) files :test #'equal)) |
---|
299 | (and (typep patch 'directory-patch) |
---|
300 | (member (patch-directory patch) files :test #'equal))) |
---|
301 | ;; If all-patches was requested, record all patches |
---|
302 | ;; matching the file criterion. |
---|
303 | (or all-patches |
---|
304 | (progn |
---|
305 | (display-patch patch *query-io*) |
---|
306 | (y-or-n-p "Record patch ~A?" patch))) |
---|
307 | nil))) |
---|
308 | (record-patches repodir patch-name author :now nil |
---|
309 | (select-patches patches #'ask)) |
---|
310 | (format t "~&Finished recording patch '~A'~%" patch-name) |
---|
311 | 0))))) |
---|
312 | |
---|
313 | (define-darcs-command pull |
---|
314 | (all-patches repodir) |
---|
315 | (&rest from-repositories) |
---|
316 | "Copy and apply patches from another repository to this one." |
---|
317 | (let* ((ourrepo |
---|
318 | (if repodir |
---|
319 | (or (fad:directory-exists-p repodir) |
---|
320 | (error "Directory ~A does not exist." repodir)) |
---|
321 | (find-repo))) |
---|
322 | ;; If explicit --repodir argument was specified, change directory. |
---|
323 | ;; Otherwise, leave it, even if the actual repository is in a |
---|
324 | ;; parent directory. |
---|
325 | (*default-pathname-defaults* |
---|
326 | (if (null repodir) |
---|
327 | *default-pathname-defaults* |
---|
328 | (fad:pathname-as-directory ourrepo)))) |
---|
329 | |
---|
330 | (if from-repositories |
---|
331 | ;; Get truename for all repositories, if they are local paths. |
---|
332 | (map-into |
---|
333 | from-repositories |
---|
334 | (lambda (dir) |
---|
335 | (setf dir (make-upath dir)) |
---|
336 | (when (typep dir 'pathname) |
---|
337 | (setf dir (or |
---|
338 | (fad:directory-exists-p dir) |
---|
339 | (error "Directory ~A does not exist." dir)))) |
---|
340 | dir) |
---|
341 | from-repositories) |
---|
342 | ;; If no remote repository specified, use the default one. |
---|
343 | (setf from-repositories (list nil))) |
---|
344 | |
---|
345 | ;; We can't pull from ourselves. |
---|
346 | (when (member ourrepo from-repositories :test #'equal) |
---|
347 | (error "Can't pull from current repository!")) |
---|
348 | |
---|
349 | (dolist (theirrepo from-repositories) |
---|
350 | (pull ourrepo theirrepo :select-patches (if all-patches :all :ask))) |
---|
351 | |
---|
352 | ;; Change the default repository. |
---|
353 | (when (first from-repositories) |
---|
354 | (set-default-repo ourrepo (upath-to-string (first from-repositories) :truename t))) |
---|
355 | |
---|
356 | 0)) |
---|
357 | |
---|
358 | (define-darcs-command get |
---|
359 | (repodir) |
---|
360 | (from) |
---|
361 | "Get a copy of a repository." |
---|
362 | (setf from (make-upath from)) |
---|
363 | (let* ((to (or |
---|
364 | ;; Either there is an explicit repodir... |
---|
365 | repodir |
---|
366 | ;; ...or we make one relative to the current directory. |
---|
367 | (make-pathname |
---|
368 | :directory |
---|
369 | (list :relative |
---|
370 | (typecase from |
---|
371 | ;; If we have a local pathname, use the last component. |
---|
372 | (pathname |
---|
373 | (or (pathname-name from) |
---|
374 | (car (last (pathname-directory from))))) |
---|
375 | ;; Otherwise, use the part from the last slash. |
---|
376 | (t |
---|
377 | (let* ((s (upath-to-string from)) |
---|
378 | (last-slash (position #\/ s :from-end t))) |
---|
379 | (if last-slash |
---|
380 | (subseq s (1+ last-slash)) |
---|
381 | s))))))))) |
---|
382 | (get-repo from to)) |
---|
383 | 0) |
---|