r7818: add argument processing using #\=, big refactoring, more tests added and passed

[kmrcl.git] / getopt.lisp

diff --git a/getopt.lisp b/getopt.lisp
index ba4cd945c47a579ff0329c9775d2160ccdedf2c9..48ec91be9a17d362e0dbdb66a26f0e8e6973a961 100644 (file)
--- a/getopt.lisp
+++ b/getopt.lisp
@@ -16,11 +16,11 @@
 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 
-(in-package #:kmr)
+(in-package #:kmrcl)
 
 
 (defun is-short-option (arg)
-  (and (= 2 (length arg))
+  (and (>= (length arg) 2)
        (char= #\- (schar arg 0))
        (char/= #\- (schar arg 1))))
 
@@ -30,22 +30,39 @@
        (char= #\- (schar arg 1))))
 
 (defun is-long-option (arg)
-  (and (> (length arg 2))
-       (char= #- (schar 0))
-       (char= #- (schar 1))
-       (char/= #- (schar 3))))
+  (and (> (length arg) 2)
+       (char= #\- (schar arg 0))
+       (char= #\- (schar arg 1))
+       (char/= #\- (schar arg 3))))
+
+(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 opts)
+(defun getopt (args options)
   "Processes a list of arguments and options. Returns filtered argument
 list and alist of options.
 opts is a list of option lists. The fields of the list are
@@ -53,14 +70,41 @@ opts is a list of option lists. The fields of the list are
  - HAS-ARG with legal values of :NONE, :REQUIRED, :OPTIONAL
  - VAL value to return for a option with no arguments
 "
-  (do ((pos args)
+  (do ((pos args (cdr pos))
+       (finished-options)
        (out-opts)
        (out-args)
        (errors))
-      ((null pos) (values out-args out-opts errors))
-    (multiple-value-bind (match is-long) (match-option (car pos) options))
-      (if match
-         (progn
-           (push (cons (car pos) (second pos)) out-opts)
-           (setq pos (cddr pos))))))
+      ((null pos) (values (nreverse out-args) (nreverse out-opts) errors))
+    (cond
+     (finished-options
+      (push (car pos) out-args))
+     ((is-option-terminator (car pos))
+      (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
+           (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)))))))))