Newer
Older
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; Free Software available under an MIT-style license. See LICENSE ;;;
;;; ;;;
;;; Copyright (c) 2003-2009 ITA Software, Inc. All rights reserved. ;;;
;;; ;;;
;;; Original author: Francois-Rene Rideau ;;;
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#+xcvb (module (:depends-on ("get-command-line-arguments")))
(in-package :command-line-arguments)
Francois-Rene Rideau
committed
;;(declaim (optimize (speed 1) (safety 3) (debug 3)))
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
(defvar *command-line-arguments* nil
"a list of strings, the arguments passed to the program on its command-line,
or what's currently left of them as they are processed")
(defvar *command-line-options* nil
"command-line options as parsed into a plist")
(defvar *command-line-option-specification* nil
"the (prepared) specification for how to parse command-line options")
;; A raw specification is a list of individual option specifications.
;; An individual option specification is:
;; A single option name or a list of option names, and a keyword/value list of option options.
;; An option name is a single character #\x for short option -x,
;; or a string "foo" for long option --foo.
;; option options are:
;; :type for specifying a parameter type for the option.
;; A type may be any of:
;; NIL - the option takes no parameter.
;; BOOLEAN - the option takes a boolean parameter. The value can be true, false, yes, no, t, nil, y, n.
;; If it's a long option, --no-foo is defined, too.
;; STRING - the option takes a string as parameter
;; INTEGER - the option takes an integer as parameter, interpreted in decimal.
;; :optional for allowing the option to have no parameter
;; for a list, it allows the final list to be empty.
;; :action for specifying an action to do when the option is found
;; an action may be a symbol to set, a function to call, nil to do nothing,
;; or a keyword to push on the option plist.
;; default action is to make a keyword from the first name.
Francois-Rene Rideau
committed
;; :list
;; the value is either T or a plist with keywords :initial-contents and :symbol.
;; The :type must be integer or string.
Francois-Rene Rideau
committed
;; :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.
Francois-Rene Rideau
committed
;; 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.
;; A counter is initialized with initial-value (by default 0),
;; 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.
Francois-Rene Rideau
committed
;; 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".
;; A *prepared* specification is an EQUAL-hash-table that maps option names to
;; a simple-vector #(action type optional) that specifies what to do when the option
;; is encountered in the command-line. It also includes three special entries for
;; keywords :local-symbol :local-values :finalizers that specify the local symbols
;; to bind when parsing options for this specification, the values to which to bind them,
;; and a list of finalizers to run after the parsing is done.
Francois-Rene Rideau
committed
(defun make-option-action (p name
&key (action nil actionp) list optional
(initial-value nil initial-value-p) &allow-other-keys)
"This is called for one option specification.
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."
Francois-Rene Rideau
committed
(let* ((actual-action (apply #'actual-action-from-spec name
(when actionp (list :action action)))))
Francois-Rene Rideau
committed
(when initial-value-p
Francois-Rene Rideau
committed
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
(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))))
Francois-Rene Rideau
committed
(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)
"Given a SPECIFICATION, return a hash table with one entry
whose key is the name and whose value is a vector of the action,
the type, and whether it's optional."
(etypecase specification
(hash-table specification)
(list
(let ((p (make-hash-table :test 'equal)))
(dolist (spec specification)
(destructuring-bind (names &rest option-options
Francois-Rene Rideau
committed
&key type optional list negation (initial-value nil initial-value-p)
action documentation negation-documentation)
spec
Francois-Rene Rideau
committed
(declare (ignorable action initial-value documentation negation-documentation))
(when initial-value-p
Francois-Rene Rideau
committed
(setf optional t))
(when list
(unless (member type '(integer string))
Francois-Rene Rideau
committed
(error "option specification ~S wants list but doesn't specify string or integer" spec)))
(let* ((namelist (if (listp names) names (list names)))
(firstname (car namelist))
(pos-action (apply 'make-option-action p firstname option-options)))
;; For each name of this spec, put an entry into the hash table
;; mapping that name to a vector of the action, the type, and
;; whether it's optional.
Francois-Rene Rideau
committed
(loop :with spec = (vector pos-action type (and optional (not list)))
:for name :in namelist :do
(setf (gethash name p) spec))
;; Deal with negation.
(when (or (eq type 'boolean) list optional)
(let ((neg-action #'(lambda (value)
(command-line-action pos-action (not value))))
(neg-names (make-negated-names namelist negation)))
Francois-Rene Rideau
committed
(loop :with spec = (vector neg-action nil nil nil)
:for name :in neg-names :do
(setf (gethash name p) spec)))))))
p))))
(defun make-negated-names (namelist &optional negation)
(let ((negation-list (if (listp negation) negation (list negation))))
Francois-Rene Rideau
committed
(loop :for name :in namelist
:when (stringp name) :do
(push (concatenate 'string "no-" name) negation-list)
(when (and (<= 7 (length name))
(string= "enable-" (subseq name 0 7)))
(push (concatenate 'string "disable-" (subseq name 7 nil))
negation-list)))
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
negation-list))
(defun command-line-option-specification (option)
(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 short-option-p (arg)
"ARG is a string. Is it like -A, but not --?"
(check-type arg simple-string)
(and (<= 2 (length arg))
(char= #\- (schar arg 0))
(char/= #\- (schar arg 1))))
(defun negated-short-option-p (arg)
"ARG is a string. Is it like +A?"
(check-type arg simple-string)
(and (<= 2 (length arg))
(char= #\+ (schar arg 0))))
(defun long-option-p (arg)
"ARG is a string. Is it like --A?"
(check-type arg simple-string)
(and (<= 3 (length arg))
(char= #\- (schar arg 0) (schar arg 1))))
(defun option-end-p (arg)
(check-type arg simple-string)
(string= arg "--"))
(defun option-like-p (arg)
(check-type arg simple-string)
(and (<= 2 (length arg))
(or (char= #\- (schar arg 0))
(char= #\+ (schar arg 0)))))
(defun option-name (option-designator)
(etypecase option-designator
(character (format nil "-~A" option-designator))
(string (format nil "--~A" option-designator))))
(defun coerce-option-parameter (option string type)
"Given a STRING option value and a TYPE, return the value as
a Lisp object. OPTION is the name of the option, just for
error messages."
(flet ((fail ()
Francois-Rene Rideau
committed
(error "parameter ~A for option ~A not of type ~A" string (option-name option) type)))
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
(ecase type
((nil)
(error "option ~A does not take a parameter" (option-name option)))
((string)
string)
((boolean)
(cond
((member string '("true" "t" "1" "yes" "y") :test #'string-equal)
t)
((member string '("false" "nil" "0" "no" "n") :test #'string-equal)
nil)
(t
(fail))))
((integer)
(multiple-value-bind (value end) (parse-integer string :junk-allowed t)
(unless (and (integerp value) (= end (length string))) (fail))
value)))))
(defun get-option-parameter (option type optional)
(cond
((member type '(boolean t nil))
t)
((and optional
(or (null *command-line-arguments*)
(option-like-p (car *command-line-arguments*))))
t)
(t
(coerce-option-parameter option (pop *command-line-arguments*) type))))
(defun process-option (option validp action parameter type optional)
(unless validp (error "Undefined option ~A" (option-name option)))
(typecase parameter
(null
(unless (or (eq type 'boolean) optional)
(error "Option ~A cannot be negated" (option-name option))))
(string
(setf parameter (coerce-option-parameter option parameter type)))
(t
(setf parameter (get-option-parameter option type optional))))
(command-line-action action parameter))
(defun process-short-option (c &key negated)
(multiple-value-bind (validp action type optional)
(command-line-option-specification c)
(process-option c validp action (not negated) type optional)))
(defun decompose-long-option-string (string)
(let* ((separator (position #\= string :start 2))
(name (subseq string 2 separator))
(parameter (if separator (subseq string (1+ separator)) t)))
(values name parameter)))
(defun process-long-option (s)
(multiple-value-bind (name parameter) (decompose-long-option-string s)
(multiple-value-bind (validp action type optional)
(command-line-option-specification name)
(process-option name validp action parameter type optional))))
(defun do-process-command-line-options ()
"Remove all the options and values from *COMMAND-LINE-ARGUMENTS*.
Process each option."
(progv
(gethash :local-symbols *command-line-option-specification*)
(gethash :local-values *command-line-option-specification*)
Francois-Rene Rideau
committed
(loop :for (function . parameters) :in (gethash :initializers *command-line-option-specification*)
:do (apply function parameters))
Francois-Rene Rideau
committed
(loop :for arg = (pop *command-line-arguments*) :do
(cond
((or (null arg) (option-end-p arg))
(return))
((short-option-p arg)
Francois-Rene Rideau
committed
(loop :for c :across (subseq arg 1 nil) :do
(process-short-option c)))
((negated-short-option-p arg)
Francois-Rene Rideau
committed
(loop :for c :across (subseq arg 1 nil) :do
(process-short-option c :negated t)))
((long-option-p arg)
(process-long-option arg))
(t
Francois-Rene Rideau
committed
(push arg *command-line-arguments*) ; put the first non-option back before we return.
Francois-Rene Rideau
committed
(loop :for (function . parameters) :in (gethash :finalizers *command-line-option-specification*)
:do (apply function parameters))))
(defun process-command-line-options (specification command-line)
"SPECIFICATION is a list as described above. COMMAND-LINE
is the list of tokens to be parsed. Return two values:
a list of alternating actions and values,
and a list of the rest of the arguments after the
various options and their values (a tail of the
COMMAND-LINE argument)."
(let*
((*command-line-option-specification*
;; The hash table describing each name.
(prepare-command-line-options-specification specification))
(*command-line-arguments*
command-line)
(*command-line-options* nil))
(do-process-command-line-options)
(values *command-line-options* *command-line-arguments*)))
(defun compute-and-process-command-line-options (specification)
(process-command-line-options specification (get-command-line-arguments)))
(defun split-sequence (sequence delimiter)
(loop
:with index = 0
:for match = (position delimiter sequence :start index)
:when (and match
(not (= index match)))
:collect (subseq sequence index match)
:when match
:do (setf index (1+ match))
:unless (or match
(= index (length sequence)))
:collect (subseq sequence index)
:while match))
Francois-Rene Rideau
committed
(defun show-option-help (specification &key (stream *standard-output*) sort-names)
;; TODO: be clever when trying to align stuff horizontally
(loop :with *print-right-margin* = (max (or *print-right-margin* 0) 100)
:for spec :in specification :do
(destructuring-bind (names &key negation documentation negation-documentation
Francois-Rene Rideau
committed
type optional list (initial-value nil initial-value-p) &allow-other-keys) spec
(declare (ignorable negation documentation negation-documentation type optional list))
Francois-Rene Rideau
committed
(unless (consp names)
(setf names (list names)))
Francois-Rene Rideau
committed
(flet ((option-names (names)
(let ((n (mapcar 'option-name names)))
(if sort-names
(stable-sort n #'< :key #'length)
n))))
(when documentation
(format stream "~& ~32A ~8A ~@<~@;~{~A ~}~@:>"
Francois-Rene Rideau
committed
(format nil "~{ ~A~}" (option-names names))
(string-downcase type)
(split-sequence documentation #\Space))
Francois-Rene Rideau
committed
(format stream "~:[~*~; (default: ~S)~]~%" initial-value-p initial-value))
(when negation-documentation
(format stream " ~32A ~8A ~@<~@;~{~A ~}~@:>~%"
Francois-Rene Rideau
committed
(format nil "~{ ~A~}" (option-names (make-negated-names names negation)))
(string-downcase type)
(split-sequence negation-documentation #\Space)))))))
#| Testing:
(defparameter *opt-spec*
'((("all" #\a) :type boolean :documentation "do it all")
("blah" :type string :initial-value "blob" :documentation "This is a very long multi line documentation. The function SHOW-OPTION-HELP should display this properly indented, that is all lines should start at the same column.")
(("verbose" #\v) :type boolean :documentation "include debugging output")
(("file" #\f) :type string :documentation "read from file instead of standard input")
(("xml-port" #\x) :type integer :optional t :documentation "specify port for an XML listener")
Francois-Rene Rideau
committed
(("http-port" #\h) :type integer :initial-value 80 :documentation "specify port for an HTTP listener")
("enable-cache" :type boolean :documentation "enable cache for queries")
("path" :type string :list t :optional t :documentation "add given directory to the path")
("port" :type integer :list (:initial-contents (1 2)) :optional t :documentation "add a normal listen on given port")))
Francois-Rene Rideau
committed
(defun foo (args &key all verbose file xml-port enable-cache port path http-port blah)
(list args :all all :verbose verbose :file file :xml-port xml-port :http-port http-port :blah blah
:enable-cache enable-cache :port port :path path))
(multiple-value-bind (options arguments)
(process-command-line-options
*opt-spec*
'("--all" "--no-verbose" "--file" "foo" "-f" "-v" "-v"
Francois-Rene Rideau
committed
"-x" "--disable-cache" "-h" "8080"
"--no-port" "--port" "3" "--port=4"
"--path" "/foo" "--path" "/bar"
"--" "--foo" "bar" "baz"))
(write arguments :pretty nil) (terpri)
(write options :pretty nil) (terpri)
(write (apply 'foo arguments options) :pretty nil)
(terpri))
(show-option-help *opt-spec*)
|#