(defun decompose-arg (arg option-type)
"Returns base-name,argument"
(let ((start (ecase option-type
- (:long 2)
- (:short 1)))
- (name-end (position #\= arg)))
+ (:long 2)
+ (:short 1)))
+ (name-end (position #\= arg)))
(values (subseq arg start name-end)
- (when name-end (subseq arg (1+ 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))))
+ ((is-long-option arg) :long)
+ (t :arg))))
(if (or (eq option-type :short) (eq option-type :long))
- (multiple-value-bind (base arg) (decompose-arg arg option-type)
- (values option-type base arg))
- (values :arg arg nil))))
+ (multiple-value-bind (base arg) (decompose-arg arg option-type)
+ (values option-type base arg))
+ (values :arg arg nil))))
(defun find-option (name options)
"Find an option in option list. Handles using unique abbreviations"
(let* ((option-names (mapcar #'car options))
- (pos (match-unique-abbreviation name option-names)))
+ (pos (match-unique-abbreviation name option-names)))
(when pos
(nth pos options))))
"Returns position of ABBR in STRINGS. ABBR may be a unique abbreviation.
Returns NIL if no match found."
(let ((len (length abbr))
- (matches nil))
+ (matches nil))
(dotimes (i (length strings))
(let* ((s (nth i strings))
- (l (length s)))
- (cond
- ((= len l)
- (when (string= abbr s)
- (push (cons s i) matches)))
- ((< len l)
- (when (string= abbr (subseq s 0 len))
- (push (cons s i) matches))))))
+ (l (length s)))
+ (cond
+ ((= len l)
+ (when (string= abbr s)
+ (push (cons s i) matches)))
+ ((< len l)
+ (when (string= abbr (subseq s 0 len))
+ (push (cons s i) matches))))))
(when (= 1 (length matches))
(cdr (first matches)))))
(setq finished-options t))
(t
(let ((arg (car pos)))
- (multiple-value-bind (option-list option-type base-name argument)
- (match-option (car pos) options)
- (cond
- ((and option-list (not (eq option-type :arg)))
- (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
- (if (or (eq :long option-type)
- (eq :short option-type))
- (push (nth-value 0 (decompose-arg arg option-type)) errors)
- (push arg out-args))))))))))
+ (multiple-value-bind (option-list option-type base-name argument)
+ (match-option (car pos) options)
+ (cond
+ ((and option-list (not (eq option-type :arg)))
+ (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
+ (if (or (eq :long option-type)
+ (eq :short option-type))
+ (push (nth-value 0 (decompose-arg arg option-type)) errors)
+ (push arg out-args))))))))))
(defun do-tests ()
(with-tests (:name "GETOPT")
(let ((*break-on-test-failures* nil))
-
+
;; match-unique-abbreviation
(test nil (match-unique-abbreviation "abc" nil))
(test nil (match-unique-abbreviation "abc" '("ab")))
(test nil (match-unique-abbreviation "ab" '("ab" "abc")))
(test 1 (match-unique-abbreviation "ac" '("ab" "ac")))
(test 1 (match-unique-abbreviation "ac" '("ab" "acb")))
-
+
;; getopt
(test-mv '(("argv") nil nil) (getopt '("argv") nil))
(test-mv '(("argv" "2") nil nil) (getopt '("argv" "2") nil))
-
+
(test-mv '(("argv") (("c")) nil) (getopt '("argv" "-c") '(("c" :none))))
-
- (test-mv '(("argv") (("c" . "val")) nil)
- (getopt '("argv" "-c" "val") '(("c" :optional))))
- (test-mv '(("argv" "v1") (("c" . "val")) nil)
- (getopt '("argv" "-c" "val" "v1") '(("c" :optional))))
- (test-mv '(( "v1") (("colon" . "val")) nil)
- (getopt '("--colon" "val" "v1") '(("colon" :optional))))
- (test-mv '(("ab" "-c") (("colon" . "val")) nil)
- (getopt '("ab" "--colon" "val" "--" "-c")
- '(("colon" :optional) ("-c" :none))))
- (test-mv '(("argv") (("c" . "cd")) nil)
- (getopt '("argv" "-c" "cd") '(("c" :required))))
- (test-mv '(("argv") nil ("c"))
- (getopt '("argv" "-c") '(("c" :required))))
- (test-mv '(("argv") (("c" . "10")) nil)
- (getopt '("argv" "-c=10") '(("c" :required))))
- (test-mv '(("argv") nil ("c"))
- (getopt '("argv" "-c=10") '(("c" :none))))
- (test-mv '(nil (("along" . "10")) nil)
- (getopt '("--along=10") '(("along" :optional))))
- (test-mv '(nil nil ("along"))
- (getopt '("--along=10") '(("along" :none))))
- (test-mv '(nil (("along" . "10")) nil)
- (getopt '("--a=10") '(("along" :optional))))
+
+ (test-mv '(("argv") (("c" . "val")) nil)
+ (getopt '("argv" "-c" "val") '(("c" :optional))))
+ (test-mv '(("argv" "v1") (("c" . "val")) nil)
+ (getopt '("argv" "-c" "val" "v1") '(("c" :optional))))
+ (test-mv '(( "v1") (("colon" . "val")) nil)
+ (getopt '("--colon" "val" "v1") '(("colon" :optional))))
+ (test-mv '(("ab" "-c") (("colon" . "val")) nil)
+ (getopt '("ab" "--colon" "val" "--" "-c")
+ '(("colon" :optional) ("-c" :none))))
+ (test-mv '(("argv") (("c" . "cd")) nil)
+ (getopt '("argv" "-c" "cd") '(("c" :required))))
+ (test-mv '(("argv") nil ("c"))
+ (getopt '("argv" "-c") '(("c" :required))))
+ (test-mv '(("argv") (("c" . "10")) nil)
+ (getopt '("argv" "-c=10") '(("c" :required))))
+ (test-mv '(("argv") nil ("c"))
+ (getopt '("argv" "-c=10") '(("c" :none))))
+ (test-mv '(nil (("along" . "10")) nil)
+ (getopt '("--along=10") '(("along" :optional))))
+ (test-mv '(nil nil ("along"))
+ (getopt '("--along=10") '(("along" :none))))
+ (test-mv '(nil (("along" . "10")) nil)
+ (getopt '("--a=10") '(("along" :optional))))
(test-mv '(nil nil ("a"))
- (getopt '("--a=10") '(("along" :optional) ("aboot" :optional))))
+ (getopt '("--a=10") '(("along" :optional) ("aboot" :optional))))
(test-mv '(("a") nil nil)
(getopt '("a") '(("a" :none))))
))