;; or a keyword to push on the option plist.
;; default action is to make a keyword from the first name.
-;; :list The value is a plist with keywords :initial-contents and :symbol.
+;; :list
+;; the value is either T or a plist with keywords :initial-contents and :symbol.
;; The :type must be integer or string.
-;; :symbol is a special variable and :initial-contents is a list.
+;; :symbol must be a special variable and
+;; :initial-contents must be a list (defaults to the provided initial-value).
;; While the options are being processed, the special variable is bound to the
;; initial contents, reversed.
-;; At the end of option processing, the finalizer reverses the list.
+;; At the end of option processing, the finalizer reverses the list and calls
+;; the action, once.
+
+;; :initial-value for specifying an initial value to call the action with
+;; before arguments are parsed. If the action is a keyword (the default)
+;; or symbol, this will provide you with a default value.
+;; :initial-value implies and overrides :optional.
;; TODO: add this feature, useful for verbose flags.
;; :count The value is a plist with keywords :initial-value and :symbol.
;; incremented each time the option is invoked, decremented each time.
;; Alternatively, if the option is given a numeric argument, the counter
;; is set to the provided argument value.
+;; TODO: add negation for lists with initial-value to allow for empty list.
;; :negation Creates string called "no-XXX", or "disable-XXX" if the original name
;; is "enable-XXX".
P is the hash table of actions. NAME is the first name of this option, a string
or a character. The keywords are option options for this option specification."
- (let* ((actual-action
- ;; This is usually the same as ACTION, but if ACTION is #'FOO,
- ;; then it's the symbol-function of FOO, and if no action is
- ;; provided, it's a keyword named NAME.
- (cond
- ((and (consp action) (eq 'function (car action))
- (consp (cdr action)) (null (cddr action)))
- (symbol-function (cadr action)))
- (actionp
- action)
- (t
- (intern (string-upcase name) :keyword))))
- (option-action
- ;; If the :LIST option is not specified, just return the actual-action.
- (if list
- (destructuring-bind (&key initial-contents (symbol (gensym (string-upcase name))))
- (and (listp list) list)
- (let ((final-action #'(lambda ()
- (let ((value (symbol-value symbol)))
- (unless (or optional value)
- (error "No option ~A defined" (option-name name)))
- (command-line-action actual-action (reverse value))))))
- (push symbol (gethash :local-symbols p))
- (push (reverse initial-contents) (gethash :local-values p))
- (push final-action (gethash :finalizers p))
- #'(lambda (value)
- (case value
- ((nil) (set symbol nil))
- ((t) (error "Option ~A requires a parameter" (option-name name)))
- (otherwise (push value (symbol-value symbol)))))))
- actual-action)))
+ (let* ((actual-action (apply #'actual-action-from-spec name
+ (when actionp (list :action action)))))
(when initial-value-p
- (push (list actual-action initial-value) (gethash :initializers p)))
- option-action))
+ (setf optional t)
+ (push (list 'command-line-action actual-action initial-value) (gethash :initializers p)))
+ ;; If the :LIST option is not specified, just return the actual-action.
+ (if (not list)
+ actual-action
+ (destructuring-bind (&key (initial-contents initial-value)
+ (symbol (gensym (string-upcase name))))
+ (and (listp list) list)
+ (push symbol (gethash :local-symbols p))
+ (push (reverse initial-contents) (gethash :local-values p))
+ (flet ((register-finalizer ()
+ (pushnew (list 'finalize-list name symbol optional actual-action)
+ (gethash :finalizers p)
+ :test 'equal)))
+ (unless optional
+ (register-finalizer))
+ #'(lambda (value)
+ (when optional
+ (register-finalizer))
+ (case value
+ ((nil) (set symbol nil))
+ ((t) (error "Option ~A requires a parameter" (option-name name)))
+ (otherwise (push value (symbol-value symbol))))))))))
+
+(defun finalize-list (name symbol optional actual-action)
+ (let ((value (symbol-value symbol)))
+ (unless (or optional value)
+ (error "No option ~A defined" (option-name name)))
+ (command-line-action actual-action (reverse value))))
+
+(defun actual-action-from-spec (name &key (action nil actionp))
+ ;; If ACTION is not provided, it's a keyword named NAME.
+ ;; If ACTION is provided, and this action is a function, nil, a keyword
+ ;; or other symbol, then it's ACTION.
+ ;; If ACTION is provided and is a list or the form (FUNCTION FOO)
+ ;; (as e.g. read by #'FOO) then it's the symbol-function of FOO.
+ ;; Otherwise, it's an error.
+ ;; See COMMAND-LINE-ACTION below for how to interpret the results.
+ (cond
+ ((not actionp)
+ (intern (string-upcase name) :keyword))
+ ((or (functionp action) (symbolp action))
+ ;; (keywordp action) and (null action) are implicitly included by symbolp
+ action)
+ ((and (consp action) (eq 'function (car action))
+ (consp (cdr action)) (null (cddr action)))
+ (symbol-function (cadr action)))
+ (t
+ (error "Invalid action spec ~S for option ~S" action name))))
+(defun command-line-action (action &optional value)
+ (etypecase action
+ (null nil)
+ (keyword (setf *command-line-options*
+ (list* action value *command-line-options*)))
+ (symbol (set action value))
+ (function (funcall action value))))
(defun prepare-command-line-options-specification (specification)
spec
(declare (ignorable action initial-value documentation negation-documentation))
(when initial-value-p
- (setf optional t)
- (when list
- (error "Invalid option spec ~S: can't be a list and have an initial-value" spec)))
+ (setf optional t))
(when list
(unless (member type '(integer string))
(error "option specification ~S wants list but doesn't specify string or integer" spec)))
(let ((v (gethash option *command-line-option-specification*)))
(if v (values t (svref v 0) (svref v 1) (svref v 2)) (values nil nil nil nil))))
-(defun command-line-action (action &optional value)
- (etypecase action
- (null nil)
- (keyword (setf *command-line-options*
- (list* action value *command-line-options*)))
- (symbol (set action value))
- (function (funcall action value))))
-
(defun short-option-p (arg)
"ARG is a string. Is it like -A, but not --?"
error messages."
(flet ((fail ()
- (error "parameter for option ~A not of type ~A" (option-name option) type)))
+ (error "parameter ~A for option ~A not of type ~A" string (option-name option) type)))
(ecase type
((nil)
(error "option ~A does not take a parameter" (option-name option)))
(progv
(gethash :local-symbols *command-line-option-specification*)
(gethash :local-values *command-line-option-specification*)
- (loop :for (action parameter) :in (gethash :initializers *command-line-option-specification*)
- :do (command-line-action action parameter))
+ (loop :for (function . parameters) :in (gethash :initializers *command-line-option-specification*)
+ :do (apply function parameters))
(loop :for arg = (pop *command-line-arguments*) :do
(cond
((or (null arg) (option-end-p arg))
((long-option-p arg)
(process-long-option arg))
(t
- (push arg *command-line-arguments*)
+ (push arg *command-line-arguments*) ; put the first non-option back before we return.
(return))))
- (loop :for f :in (gethash :finalizers *command-line-option-specification*)
- :do (funcall f))))
+ (loop :for (function . parameters) :in (gethash :finalizers *command-line-option-specification*)
+ :do (apply function parameters))))
(defun process-command-line-options (specification command-line)
common-lisp.net / projects/qitab/command-line-arguments.git / commitdiff
