(defun is-short-option (arg)
- (and (= 2 (length arg))
+ (and (>= (length arg) 2)
(char= #\- (schar arg 0))
(char/= #\- (schar arg 1))))
(char= #\- (schar arg 1))
(char/= #\- (schar arg 3))))
-(defun arg->base-name (arg)
- (cond
- ((is-long-option arg)
- (subseq arg 2))
- ((is-short-option arg)
- (subseq arg 1))
- (t
- arg)))
-
+(defun arg->base-name (arg option-type)
+ "returns base-name,argument"
+ (let ((start (ecase option-type
+ (:long 2)
+ (:short 1)))
+ (name-end (position #\= arg)))
+
+ (values (subseq arg start name-end)
+ (when name-end (subseq arg (1+ name-end))))))
+
+(defun analyze-arg (arg)
+ "Analyzes an argument. Returns option-type,base-name,argument"
+ (let* ((option-type (cond ((is-short-option arg) :short)
+ ((is-long-option arg) :long)
+ (t :arg))))
+ (if (or (eq option-type :short) (eq option-type :long))
+ (multiple-value-bind (base arg) (arg->base-name arg option-type)
+ (values option-type base arg))
+ (values :arg arg nil))))
+
+
(defun match-option (arg options)
- "Matches an argument to an option. Returns match,is-long"
- (cond
- ((is-long-option arg)
- (values (find (subseq arg 2) options :key #'car :test #'equal) :long))
- ((is-short-option arg)
- (values (find (subseq arg 1) options :key #'car :test #'equal) :short))
- (t
- (values nil nil))))
+ "Matches an argument to an option. Returns option-list,option-type,base-name,argument"
+ (multiple-value-bind (option-type base-name argument) (analyze-arg arg)
+ (let ((match (find base-name options :key #'car :test #'equal)))
+ (values match option-type base-name argument))))
(defun getopt (args options)
"Processes a list of arguments and options. Returns filtered argument
((is-option-terminator (car pos))
(setq finished-options t))
(t
- (multiple-value-bind (match is-long) (match-option (car pos) options)
- (if match
- (cond
- ((and (eq :required (second match)) (null (cdr pos)))
- (push (arg->base-name (car pos)) errors))
- (t
- (push (cons (arg->base-name (car pos)) (second pos)) out-opts)
- (setq pos (cdr pos))))
- (push (car pos) out-args)))))))
+ (let ((arg (car pos)))
+ (multiple-value-bind (option-list option-type base-name argument)
+ (match-option (car pos) options)
+ (cond
+ (option-list
+ (cond
+ (argument
+ (case (second option-list)
+ (:none
+ (push base-name errors))
+ (t
+ (push (cons base-name argument) out-opts))))
+ ((null argument)
+ (if (and (eq :required (second option-list)) (null (cdr pos)))
+ (push base-name errors)
+ (if (or (is-short-option (second pos))
+ (is-long-option (second pos)))
+ (if (eq :required (second option-list))
+ (push base-name errors)
+ (push (cons base-name (third option-list)) out-args))
+ (progn
+ (push (cons base-name (second pos)) out-opts)
+ (setq pos (cdr pos))))))))
+ (t
+ (push arg out-args)))))))))