[Cl-darcs-cvs] r158 - cl-darcs/trunk
mhenoch at common-lisp.net
mhenoch at common-lisp.net
Thu Jan 31 18:06:52 UTC 2008
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=)
More information about the Cl-darcs-cvs
mailing list