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 ,@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 + ,@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=)