Newer
Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
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
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
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
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
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
254
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
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; Confidential and proprietary information of ITA Software, Inc. ;;;
;;; ;;;
;;; 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)
(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.
;; :list The value is 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.
;; 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.
;; 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.
;; :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.
(defun make-option-action (p name &key (action nil actionp) list optional &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."
(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)))))
;; 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)))
(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
&key type optional list negation
action documentation negation-documentation)
spec
(declare (ignorable action documentation negation-documentation))
(when list
(unless (member type '(integer string))
(error "option specification wants list but doesn't specify string or integer")))
(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.
(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)))
(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))))
(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)))
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 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 --?"
(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 ()
(error "parameter for option ~A not of type ~A" (option-name option) type)))
(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*)
(loop for arg = (pop *command-line-arguments*) do
(cond
((or (null arg) (option-end-p arg))
(return))
((short-option-p arg)
(loop for c across (subseq arg 1 nil) do
(process-short-option c)))
((negated-short-option-p arg)
(loop for c across (subseq arg 1 nil) do
(process-short-option c :negated t)))
((long-option-p arg)
(process-long-option arg))
(t
(push arg *command-line-arguments*)
(return))))
(loop for f in (gethash :finalizers *command-line-option-specification*)
do (funcall f))))
(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 show-option-help (specification &optional (stream *standard-output*))
;; TODO: be clever when trying to align stuff vertically
(loop :for spec :in specification :do
(destructuring-bind (names &key negation documentation negation-documentation
type optional list &allow-other-keys) spec
(declare (ignorable negation documentation negation-documentation type optional list))
(when documentation
(format stream " ~25A ~A~%"
(format nil "~{ ~A~}" (mapcar 'option-name names))
documentation))
(when negation-documentation
(format stream " ~25A ~A~%"
(format nil "~{ ~A~}" (mapcar 'option-name (make-negated-names names negation)))
negation-documentation)))))
#| Testing:
(defparameter *opt-spec*
'((("all" #\a) :type boolean :documentation "do it all")
(("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")
("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")))
(defun foo (args &key all verbose file xml-port enable-cache port path)
(list args :all all :verbose verbose :file file :xml-port xml-port
: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"
"-x" "--disable-cache"
"--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*)
|#