Author: mhenoch Date: Tue Jan 8 13:09:17 2008 New Revision: 157 Modified: cl-darcs/trunk/cmdline.lisp Log: Hack "add" command for error messages conforming to darcs' test suite, etc Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Tue Jan 8 13:09:17 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2007 Magnus Henoch +;;; Copyright (C) 2007, 2008 Magnus Henoch ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -27,6 +27,9 @@ "Turn a command symbol into a function symbol." (intern (format nil "CMD-~A" command) :darcs))) +(define-condition invalid-arguments (simple-error) + ()) + (defun handle-command-line (argv) "Handle a command line, emulating the real darcs client. ARGV is a list of strings. This function is to be called in some @@ -41,10 +44,24 @@ (format *error-output* "Invalid command '~A'!~%" (car argv))) (usage) 1) - (handler-case - (apply function (cdr argv)) + (handler-case + (let ((retval (apply function (cdr argv)))) + (fresh-line) + (if (numberp retval) + retval + (progn + (warn "~A didn't give a proper exit code." command) + 0))) + ;; Catch wrong number of arguments (program-error () (command-usage command) + 1) + (invalid-arguments (c) + (with-accessors ((ctrl simple-condition-format-control) + (args simple-condition-format-arguments)) c + (when ctrl + (apply #'format *error-output* ctrl args))) + (command-usage command) 1))))) (defun usage () @@ -60,7 +77,7 @@ (defun command-usage (command) "Print longer documentation for COMMAND." - (format *error-output* "~A~%" (documentation (command-function command) 'function))) + (format *error-output* "~&~A~%" (documentation (command-function command) 'function))) (defmacro define-darcs-command (name arglist docstring &body body) (let ((function (command-function name))) @@ -79,10 +96,47 @@ "Add files and directories for later recording. Usage: darcs add FILE ..." - (let ((repo (find-repo))) + (let ((repo (find-repo)) + already-there) (dolist (file files-and-dirs) - (add-file repo file) - (format t "~&Added ~A" file)))) + (handler-case + (progn + (add-file repo file) + ;; (format t "~&Added ~A" file) + ) + (already-in-repository (c) + ;; Save the files and directories that are already in the + ;; repository for pretty error printing. + (push (slot-value c 'file) already-there)))) + (when already-there + (setf already-there (nreverse already-there)) + (let* ((with-path (mapcar (lambda (f) (merge-pathnames f repo)) already-there)) + (nfiles 0) + (ndirs 0)) + (dolist (f with-path) + (let ((truename (fad:file-exists-p f))) + (assert truename) + (if (fad:directory-pathname-p f) + (incf ndirs) + (incf nfiles)))) + (assert (= (+ nfiles ndirs) (length already-there))) + ;; We want the message to look just like darcs', in order to + ;; pass its test suite (in particular tests/add.pl). + (format *error-output* + "~&The following ~A already in the repository" + (cond + ((zerop nfiles) + (if (= ndirs 1) + "directory is" + "directories are")) + ((zerop ndirs) + (if (= nfiles 1) + "file is" + "files are")) + (t + "files and directories are"))) + (format *error-output* ":~%~{ ~A~}" already-there)))) + 0) (define-darcs-command whatsnew () "See what has been changed in the working directory. @@ -98,12 +152,20 @@ (multiple-value-bind (operands options errors) (getopt:getopt args '(("repodir" :required))) - (declare (ignore operands)) + (unless (null operands) + (error 'invalid-arguments + :format-control "Invalid arguments: ~@{ ~A~}" + :format-arguments operands)) (if errors - (progn - (format *error-output* "Invalid arguments: ~{ ~A ~}~%" errors) - 1) + (error 'invalid-arguments + :format-control "Invalid arguments: ~@{ ~A~}" + :format-arguments errors) (let ((repodir (or (cdr (assoc "repodir" options :test #'string=)) *default-pathname-defaults*))) - (format t "Creating repo in ~S...~%" repodir) - (create-repo (truename repodir)))))) + (format t "Creating repo in ~A...~%" repodir) + (create-repo repodir) + 0)))) + +(define-darcs-command record (&rest args) + "Save changes in the working copy to the repository as a patch." + )