From mhenoch at common-lisp.net Tue Jan 8 18:02:20 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Tue, 8 Jan 2008 13:02:20 -0500 (EST) Subject: [Cl-darcs-cvs] r149 - cl-darcs/trunk Message-ID: <20080108180220.DF9937C046@common-lisp.net> Author: mhenoch Date: Tue Jan 8 13:02:20 2008 New Revision: 149 Modified: cl-darcs/trunk/apply-patch.lisp Log: Fix error signalling when file to create already exists Modified: cl-darcs/trunk/apply-patch.lisp ============================================================================== --- cl-darcs/trunk/apply-patch.lisp (original) +++ cl-darcs/trunk/apply-patch.lisp Tue Jan 8 13:02:20 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2006, 2007 Magnus Henoch +;;; Copyright (C) 2006, 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 @@ -107,9 +107,10 @@ (let ((new-file (merge-pathnames (patch-filename patch) repodir))) (dformat "~&Creating file ~A." new-file) - (open new-file :direction :probe - :if-does-not-exist :create - :if-exists :error))) + (with-open-file (f new-file :direction :output + :if-does-not-exist :create + :if-exists :error) + (declare (ignore f))))) (defmethod apply-patch ((patch binary-patch) repodir) "Apply a binary patch in REPODIR." From mhenoch at common-lisp.net Tue Jan 8 18:04:03 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Tue, 8 Jan 2008 13:04:03 -0500 (EST) Subject: [Cl-darcs-cvs] r150 - cl-darcs/trunk Message-ID: <20080108180403.1E6E27C046@common-lisp.net> Author: mhenoch Date: Tue Jan 8 13:04:02 2008 New Revision: 150 Modified: cl-darcs/trunk/diff.lisp Log: Signal an error when adding a file or directory that already exists Modified: cl-darcs/trunk/diff.lisp ============================================================================== --- cl-darcs/trunk/diff.lisp (original) +++ cl-darcs/trunk/diff.lisp Tue Jan 8 13:04:02 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2006, 2007 Magnus Henoch +;;; Copyright (C) 2006, 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 @@ -157,7 +157,10 @@ (typecase p (add-file-patch (let ((pathname-string (pathname-to-string (patch-filename p))) + (old-file (merge-pathnames (patch-filename p) pristine)) (new-file (merge-pathnames (patch-filename p) repo))) + (when (fad:file-exists-p old-file) + (error "Pending add of file ~A, but it already exists in the repository." pathname-string)) (setf patches (nconc patches (list* p @@ -165,6 +168,10 @@ (diff-binary-file nil new-file :filename pathname-string) (diff-file nil new-file :filename pathname-string))))))) (add-dir-patch + (let ((pathname-string (pathname-to-string (patch-directory p))) + (old-dir (merge-pathnames (patch-directory p) pristine))) + (when (fad:directory-exists-p old-dir) + (error "Pending add of directory ~A, but it already exists in the repository." pathname-string))) (setf patches (nconc patches (list p)))) (t (push p pruned-pending)))) From mhenoch at common-lisp.net Tue Jan 8 18:05:10 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Tue, 8 Jan 2008 13:05:10 -0500 (EST) Subject: [Cl-darcs-cvs] r151 - cl-darcs/trunk Message-ID: <20080108180510.0E9007C046@common-lisp.net> Author: mhenoch Date: Tue Jan 8 13:05:09 2008 New Revision: 151 Modified: cl-darcs/trunk/equal.lisp Log: Make EQUAL-PATCH work for ADD-FILE-PATCH and RM-FILE-PATCH Modified: cl-darcs/trunk/equal.lisp ============================================================================== --- cl-darcs/trunk/equal.lisp (original) +++ cl-darcs/trunk/equal.lisp Tue Jan 8 13:05:09 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2006 Magnus Henoch +;;; Copyright (C) 2006, 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 @@ -47,6 +47,14 @@ (equal (patch-filename a) (patch-filename b))) (call-next-method))) +(defmethod equal-patch ((a file-patch) (b file-patch) &optional really) + "Compare two simple file patches. +If the :around method proceeds to call us, and there is no more specific +method, then we have two ADD-FILE-PATCHes or RM-FILE-PATCHES, which are +equal." + (declare (ignore really)) + t) + (defmethod equal-patch ((a hunk-patch) (b hunk-patch) &optional really) "Compare two hunk patches." (declare (ignore really)) From mhenoch at common-lisp.net Tue Jan 8 18:05:49 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Tue, 8 Jan 2008 13:05:49 -0500 (EST) Subject: [Cl-darcs-cvs] r152 - cl-darcs/trunk Message-ID: <20080108180549.863BB7C046@common-lisp.net> Author: mhenoch Date: Tue Jan 8 13:05:49 2008 New Revision: 152 Modified: cl-darcs/trunk/get.lisp Log: CREATE-REPO: Create directory if it doesn't exist. Always make an empty pristine tree. Modified: cl-darcs/trunk/get.lisp ============================================================================== --- cl-darcs/trunk/get.lisp (original) +++ cl-darcs/trunk/get.lisp Tue Jan 8 13:05:49 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2006, 2007 Magnus Henoch +;;; Copyright (C) 2006, 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 @@ -19,8 +19,15 @@ (defun create-repo (repodir) "Create an empty repository." (setf repodir (fad:pathname-as-directory repodir)) + + ;; Create the directory if it doesn't exist, then get the absolute + ;; path. + (ensure-directories-exist repodir) + (setf repodir (truename repodir)) + + ;; Darcsify it. (prepare-new-repo repodir) - (create-pristine-from-tree repodir)) + (create-empty-pristine repodir)) ;; get_cmd in Get.lhs (defun get-repo (inrepodir outname &key (partial nil) (query nil)) From mhenoch at common-lisp.net Tue Jan 8 18:06:26 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Tue, 8 Jan 2008 13:06:26 -0500 (EST) Subject: [Cl-darcs-cvs] r153 - cl-darcs/trunk Message-ID: <20080108180626.ABDB97C046@common-lisp.net> Author: mhenoch Date: Tue Jan 8 13:06:26 2008 New Revision: 153 Modified: cl-darcs/trunk/util.lisp Log: Ignore duplicated slashes in filenames Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Tue Jan 8 13:06:26 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2006, 2007 Magnus Henoch +;;; Copyright (C) 2006, 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 @@ -205,7 +205,7 @@ Signal an error if FILENAME doesn't denote a relative path going strictly down. If TYPE is :DIRECTORY, return pathname in directory form." - (let ((components (split-sequence:split-sequence #\/ filename))) + (let ((components (split-sequence:split-sequence #\/ filename :remove-empty-subseqs t))) (setf components (delete "." components :test #'string=)) (when (member ".." components :test #'string=) (error "Filename ~S tries to go up in directory tree." filename)) From mhenoch at common-lisp.net Tue Jan 8 18:06:58 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Tue, 8 Jan 2008 13:06:58 -0500 (EST) Subject: [Cl-darcs-cvs] r154 - cl-darcs/trunk Message-ID: <20080108180658.AA88D7C046@common-lisp.net> Author: mhenoch Date: Tue Jan 8 13:06:58 2008 New Revision: 154 Modified: cl-darcs/trunk/write-patch.lisp Log: Write directory patches without trailing slash Modified: cl-darcs/trunk/write-patch.lisp ============================================================================== --- cl-darcs/trunk/write-patch.lisp (original) +++ cl-darcs/trunk/write-patch.lisp Tue Jan 8 13:06:58 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2006 Magnus Henoch +;;; Copyright (C) 2006, 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 @@ -69,7 +69,9 @@ (defun write-token-and-filename (token filename stream) (write-as-bytes token stream) (write-byte 32 stream) - (write-as-bytes (pathname-to-string filename) stream) + ;; Both files and directories are specified in file format, + ;; i.e. without a trailing slash. + (write-as-bytes (pathname-to-string (fad:pathname-as-file filename)) stream) (write-byte 10 stream)) (defmethod write-patch ((patch add-file-patch) stream) From mhenoch at common-lisp.net Tue Jan 8 18:08:02 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Tue, 8 Jan 2008 13:08:02 -0500 (EST) Subject: [Cl-darcs-cvs] r155 - cl-darcs/trunk Message-ID: <20080108180802.2AE297C046@common-lisp.net> Author: mhenoch Date: Tue Jan 8 13:08:01 2008 New Revision: 155 Added: cl-darcs/trunk/condition.lisp Modified: cl-darcs/trunk/cl-darcs.asd cl-darcs/trunk/pending.lisp cl-darcs/trunk/record.lisp Log: Remove pending patches after they are committed Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Tue Jan 8 13:08:01 2008 @@ -27,7 +27,8 @@ :components ((:file "packages") - (:file "util" :depends-on ("packages" #-allegro "inflate")) + (:file "condition" :depends-on ("packages")) + (:file "util" :depends-on ("packages" "condition" #-allegro "inflate")) (:file "unreadable-stream" :depends-on ("packages")) (:file "upath" :depends-on ("util" #|"binary-text"|#)) Added: cl-darcs/trunk/condition.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/condition.lisp Tue Jan 8 13:08:01 2008 @@ -0,0 +1,27 @@ +;;; Copyright (C) 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 +;;; published by the Free Software Foundation; either version 2 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(in-package :darcs) + +(define-condition repository-condition () + ((repository :initarg :repository :type pathname + :documentation "The absolute path of the concerned repository.")) + (:documentation "Base class for conditions concerning a repository.")) + +(define-condition repository-file-condition (repository-condition) + ((file :initarg :file :type pathname + :documentation "The relative path of the concerned file or directory.")) + (:documentation "Base class for conditions concerning a file in a repository.")) Modified: cl-darcs/trunk/pending.lisp ============================================================================== --- cl-darcs/trunk/pending.lisp (original) +++ cl-darcs/trunk/pending.lisp Tue Jan 8 13:08:01 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 @@ -26,16 +26,34 @@ (when (probe-file pending-file) (read-patch-from-file pending-file :compressed nil)))) +(defun write-pending (repodir patch) + "Write PATCH to the \"pending\" file in REPODIR. +The previous file is overwritten." + (declare (type (or null composite-patch) patch)) + (if (and patch (patches patch)) + (with-open-file (out (pending-filename repodir) + :direction :output :element-type '(unsigned-byte 8) + :if-exists :supersede) + (write-patch patch out)) + (delete-file (pending-filename repodir)))) + (defun add-to-pending (repodir patch) "Add PATCH to the list of \"pending\" patches in REPODIR." (let ((pending (read-pending repodir))) (when (null pending) (setf pending (make-instance 'composite-patch))) (setf (patches pending) (append (patches pending) (list patch))) - (with-open-file (out (pending-filename repodir) - :direction :output :element-type '(unsigned-byte 8) - :if-exists :supersede) - (write-patch pending out)))) + (write-pending repodir pending))) + +(defun remove-matching-from-pending (repodir patches) + "Remove PATCHES from the list of \"pending\" patches in REPODIR." + ;; Currently we only have ADD-FILE-PATCH and ADD-DIR-PATCH in + ;; pending, which can be compared by EQUAL-PATCH. + (let ((pending (read-pending repodir))) + (when pending + (setf (patches pending) + (nset-difference (patches pending) patches :test #'equal-patch)) + (write-pending repodir pending)))) (defun add-file (repo file) "Schedule FILE for recording to REPO. @@ -52,10 +70,23 @@ (let ((pristine-file (merge-pathnames file (upath-subdir repo '("_darcs" "pristine")))) (working-file (merge-pathnames file repo))) - (when (if (eql type :file) - (fad:file-exists-p pristine-file) - (fad:directory-exists-p pristine-file)) - (error "~A already exists in the repository." (pathname-to-string file))) + ;; XXX: does this work properly for directories? + (when (or + ;; Is file/directory already committed? + (if (eql type :file) + (fad:file-exists-p pristine-file) + (fad:directory-exists-p pristine-file)) + ;; Or is it already added to pending? + (let* ((pending (read-pending repo)) + (patches (when pending (patches pending)))) + (or + (find file patches + :key (lambda (p) (when (typep p 'add-file-patch) (patch-filename p))) + :test #'equal) + (find file patches + :key (lambda (p) (when (typep p 'add-dir-patch) (patch-directory p))) + :test #'equal)))) + (error 'already-in-repository :repository repo :file file)) (when (not (if (eql type :file) (fad:file-exists-p working-file) (fad:directory-exists-p working-file))) @@ -66,4 +97,13 @@ repo (if (eql type :file) (make-instance 'add-file-patch :filename file) - (make-instance 'add-dir-patch :directory file))))) \ No newline at end of file + (make-instance 'add-dir-patch :directory file))))) + +(define-condition already-in-repository (repository-file-condition error) + () + (:documentation "The file to be added already exists in the repository.") + (:report (lambda (condition stream) + (format stream + "~A already exists in the repository in ~A." + (slot-value condition 'file) + (slot-value condition 'repository))))) Modified: cl-darcs/trunk/record.lisp ============================================================================== --- cl-darcs/trunk/record.lisp (original) +++ cl-darcs/trunk/record.lisp Tue Jan 8 13:08:01 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2006 Magnus Henoch +;;; Copyright (C) 2006, 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 @@ -43,6 +43,7 @@ :patches patches)))) (write-patch-to-repo patch repo) (apply-patch-to-pristine patch repo) + (remove-matching-from-pending repo patches) (append-inventory repo patchinfo))) (defun record-changes (repo name author date log) From mhenoch at common-lisp.net Tue Jan 8 18:08:36 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Tue, 8 Jan 2008 13:08:36 -0500 (EST) Subject: [Cl-darcs-cvs] r156 - cl-darcs/trunk Message-ID: <20080108180836.6477E7C046@common-lisp.net> Author: mhenoch Date: Tue Jan 8 13:08:36 2008 New Revision: 156 Modified: cl-darcs/trunk/pristine.lisp Log: Add CREATE-EMPTY-PRISTINE Modified: cl-darcs/trunk/pristine.lisp ============================================================================== --- cl-darcs/trunk/pristine.lisp (original) +++ cl-darcs/trunk/pristine.lisp Tue Jan 8 13:08:36 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2006 Magnus Henoch +;;; Copyright (C) 2006, 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 @@ -16,6 +16,10 @@ (in-package :darcs) +(defun create-empty-pristine (repodir) + "Make an empty pristine tree in REPODIR." + (make-dir (upath-subdir repodir '("_darcs" "pristine")))) + (defun create-pristine-from-tree (repodir) "Copy the checked-out tree at REPODIR to get a pristine tree." (let* ((darcs-dir (upath-subdir repodir '("_darcs"))) From mhenoch at common-lisp.net Tue Jan 8 18:09:18 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Tue, 8 Jan 2008 13:09:18 -0500 (EST) Subject: [Cl-darcs-cvs] r157 - cl-darcs/trunk Message-ID: <20080108180918.2A3167C046@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." + ) From mhenoch at common-lisp.net Thu Jan 31 18:06:52 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Thu, 31 Jan 2008 13:06:52 -0500 (EST) Subject: [Cl-darcs-cvs] r158 - cl-darcs/trunk Message-ID: <20080131180652.E18964911A@common-lisp.net> Author: mhenoch Date: Thu Jan 31 13:06:52 2008 New Revision: 158 Added: cl-darcs/trunk/getopt.lisp Modified: cl-darcs/trunk/cl-darcs.asd cl-darcs/trunk/cmdline.lisp cl-darcs/trunk/util.lisp Log: Use more elaborate options framework for command line tool Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Thu Jan 31 13:06:52 2008 @@ -22,8 +22,7 @@ ;; Regexps :cl-ppcre ;; Diff - :cl-difflib - :getopt) + :cl-difflib) :components ((:file "packages") @@ -39,7 +38,8 @@ (:file "prefs" :depends-on ("util")) (:file "repo" :depends-on ("util")) (:file "diff" :depends-on ("util")) - (:file "cmdline" :depends-on ("util")) + (:file "getopt" :depends-on ("packages")) + (:file "cmdline" :depends-on ("util" "getopt")) (:file "patch-core" :depends-on ("util")) (:file "record" :depends-on ("patch-core")) Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Thu Jan 31 13:06:52 2008 @@ -45,7 +45,7 @@ (usage) 1) (handler-case - (let ((retval (apply function (cdr argv)))) + (let ((retval (funcall function (cdr argv)))) (fresh-line) (if (numberp retval) retval @@ -53,7 +53,8 @@ (warn "~A didn't give a proper exit code." command) 0))) ;; Catch wrong number of arguments - (program-error () + (program-error (c) + (format *error-output* "~&Program error: ~A" c) (command-usage command) 1) (invalid-arguments (c) @@ -79,11 +80,33 @@ "Print longer documentation for COMMAND." (format *error-output* "~&~A~%" (documentation (command-function command) 'function))) -(defmacro define-darcs-command (name arglist docstring &body body) - (let ((function (command-function name))) - `(progn - (pushnew ',name *darcs-commands*) - (defun ,function ,arglist ,docstring , at body)))) +(defmacro define-darcs-command (name options operands docstring &body body) + "Define a darcs command called NAME. +NAME is passed to COMMAND-FUNCTION to make the name of the function. +OPTIONS is a list of variables holding OPTION structures, describing +the options accepted by the commnad. +OPERANDS is a destructuring lambda list for the non-option arguments +accepted by the command." + (flet ((option-symbol (name) + (intern (concatenate 'string "OPT-" (symbol-name name))))) + (let ((function (command-function name)) + (args-sym (gensym)) + (options-sym (gensym)) + (operands-sym (gensym))) + `(progn + (pushnew ',name *darcs-commands*) + (defun ,function (,args-sym) ,docstring + (multiple-value-bind (,options-sym ,operands-sym) + (getopt ,args-sym + (list ,@(mapcar #'option-symbol options))) + ,@(when (null options) + `((declare (ignore ,options-sym)))) + (let ,(mapcar + (lambda (o) + `(,o (cdr (assoc (option-keyword ,(option-symbol o)) ,options-sym)))) + options) + (destructuring-bind ,operands ,operands-sym + , at body)))))))) (defun find-repo () "Find repository in current directory. @@ -92,7 +115,7 @@ (error "Not in a darcs repo.")) *default-pathname-defaults*) -(define-darcs-command add (&rest files-and-dirs) +(define-darcs-command add () (&rest files-and-dirs) "Add files and directories for later recording. Usage: darcs add FILE ..." @@ -138,34 +161,100 @@ (format *error-output* ":~%~{ ~A~}" already-there)))) 0) -(define-darcs-command whatsnew () +(define-darcs-command whatsnew () () "See what has been changed in the working directory. Usage: darcs whatsnew" (diff-repo-display (find-repo))) -(define-darcs-command init (&rest args) +(defparameter opt-repodir + (make-option + :keyword :repodir + :long "repodir" + :arg "DIRECTORY" + :help "Use DIRECTORY instead of current directory")) + +(define-darcs-command init (repodir) () "Initialize a darcs repository in the current directory. Options: --repodir=DIRECTORY Use DIRECTORY instead of current directory" - (multiple-value-bind (operands options errors) - (getopt:getopt args - '(("repodir" :required))) - (unless (null operands) - (error 'invalid-arguments - :format-control "Invalid arguments: ~@{ ~A~}" - :format-arguments operands)) - (if errors - (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 ~A...~%" repodir) - (create-repo repodir) - 0)))) - -(define-darcs-command record (&rest args) + (let ((repodir (or repodir + *default-pathname-defaults*))) + (format t "Creating repo in ~A...~%" repodir) + (create-repo repodir) + 0)) + +(defparameter opt-author + (make-option + :keyword :author + :short #\A + :long "author" + :arg "EMAIL" + :help "specify author id")) + +(defparameter opt-all-patches + (make-option + :keyword :all-patches + :short #\a + :long "all" + :help "answer yes to all patches")) + +(defparameter opt-patch-name + (make-option + :keyword :patch-name + :short #\m + :long "patch-name" + :arg "PATCHNAME" + :help "name of patch")) + +(defparameter opt-ask-deps + (make-option + :keyword :ask-deps + :long "ask-deps" + :help "ask for extra dependencies")) + +(define-darcs-command record + (author all-patches patch-name ask-deps) + (&rest files) "Save changes in the working copy to the repository as a patch." - ) + (let* ((repo (find-repo)) + (author (or author + ;; XXX: other ways to indicate author + (progn + (format *query-io* "~&Who is the author? ") + (read-line *query-io*)))) + (patch-name (or patch-name + (progn + (format *query-io* "~&What is the patch name? ") + (read-line *query-io*)))) + (files (mapcar + (lambda (file) + (setf file (enough-namestring file repo)) + (if (fad:directory-exists-p file) + (sanitize-filename file :type :directory) + (sanitize-filename file :type :file))) + files))) + ;; XXX: long log + + (let ((patches (diff-repo repo))) + (flet ((ask (patch) + ;; If any files were specified, use only patches + ;; touching those files/directories. + (if (or (null files) + (and (typep patch 'file-patch) + (member (patch-filename patch) files :test #'equal)) + (and (typep patch 'directory-patch) + (member (patch-directory patch) files :test #'equal))) + ;; If all-patches was requested, record all patches + ;; matching the file criterion. + (or all-patches + (progn + (display-patch patch *query-io*) + (y-or-n-p "Record patch ~A?" patch))) + nil))) + (record-patches repo patch-name author :now nil + (select-patches patches #'ask)) + (format t "~&Finished recording patch '~A'~%" patch-name) + 0)))) + Added: cl-darcs/trunk/getopt.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/getopt.lisp Thu Jan 31 13:06:52 2008 @@ -0,0 +1,105 @@ +;;; Copyright (C) 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 +;;; published by the Free Software Foundation; either version 2 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(in-package :darcs) + +;; The option struct describes a command line option. +(defstruct option + ;; keyword for return value of GETOPT + (keyword (error "No keyword specified.") :type keyword) + ;; short name of one character + (short nil :type (or character null)) + ;; long name + (long nil :type (or string null)) + ;; does it take an argument? if so, describe the argument type. + (arg nil :type (or string null)) + ;; one-line help string + (help (error "No help string specified.") :type string)) + +(defun getopt (args options &aux parsed leftover) + "Process command line ARGS, as specified by OPTIONS. +ARGS is a list of strings. +OPTIONS is a list of OPTION structs. + +Return two values: a alist of parsed options, and a list of leftover args. +The keys of the alists are the keywords of the options found, and the +values are the provided arguments, or T if the option takes no argument." + (flet ((what (arg) + (cond + ((string= arg "--") + :pass) + ((and (>= (length arg) 2) + (string= arg "--" :end1 2)) + :long) + ((and (>= (length arg) 1) + (string= arg "-" :end1 1)) + :short) + (t + nil))) + (maybe-get-argument (arg opt &key no-argument) + (push (cons (option-keyword opt) + (if (option-arg opt) + (if (or no-argument (null args)) + (error "Option ~A requires an argument." arg) + (pop args)) + t)) + parsed)) + (maybe-split-long-option (arg) + (let ((equal-pos (position #\= arg))) + (if equal-pos + (progn + (push (subseq arg (1+ equal-pos)) args) + (subseq arg 2 equal-pos)) + (subseq arg 2))))) + + (loop while args do + (ecase (what (car args)) + (:pass + ;; Got "--". Skip it and return the remaining arguments + ;; without checking. + (pop args) + (return-from getopt (values parsed (append (nreverse leftover) args)))) + + (:long + ;; Got a long option. Identify it and retrieve its + ;; argument, if any. + (let* ((arg (pop args)) + (long-option (maybe-split-long-option arg)) + (option (find long-option options :key #'option-long :test #'string=))) + (unless option + (error "Unknown long option ~S (none of ~{~S ~})." arg (mapcar #'option-long options))) + (maybe-get-argument arg option))) + + (:short + ;; Got a string of short options. Identify them all. + (let* ((arg (pop args)) + (letters (map 'list #'identity (subseq arg 1)))) + + (loop while letters + do + (let* ((letter (pop letters)) + (option (find letter options :key #'option-short))) + (unless option + (error "Unknown option ~A." letter)) + ;; Only the last short option can have an argument. + (maybe-get-argument letter option + :no-argument (not (null letters))))))) + + ((nil) + ;; Not an option - leftover args. + (push (pop args) leftover)))) + + (values parsed (nreverse leftover)))) Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Thu Jan 31 13:06:52 2008 @@ -205,6 +205,7 @@ Signal an error if FILENAME doesn't denote a relative path going strictly down. If TYPE is :DIRECTORY, return pathname in directory form." + (declare (type (member :file :directory) type)) (let ((components (split-sequence:split-sequence #\/ filename :remove-empty-subseqs t))) (setf components (delete "." components :test #'string=)) (when (member ".." components :test #'string=)