[Cl-darcs-cvs] r157 - cl-darcs/trunk

[mhenoch at common-lisp.net]

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."
+  )