source: cl-darcs/trunk/cmdline.lisp

Last change on this file was 204, checked in by Magnus Henoch, 14 years ago

Note todo items for command operands

File size: 12.5 KB
Line 
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.
21Each element is a symbol that names the command.  The corresponding
22function is named cmd-SYMBOL, and is called with all command line
23arguments 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.
32ARGV is a list of strings.  This function is to be called in some
33platform-dependent manner, while being portable itself.  An integer
34exit 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.
77NAME is passed to COMMAND-FUNCTION to make the name of the function.
78OPTIONS is a list of variables holding OPTION structures, describing
79the options accepted by the commnad.
80OPERANDS is a destructuring lambda list for the non-option arguments
81accepted 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.
142Signal an error if there is none, else return the repository root.
143If 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.
157That is, if there is no --repodir option, don't change current directory,
158and bind variable to the repository root directory.
159If there is a --repodir option, ensure it refers to an existing directory,
160and 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
182Usage: 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
227Usage: 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)
Note: See TracBrowser for help on using the repository browser.