From: Kevin M. Rosenberg <kevin@rosenberg.net>
Date: Wed, 10 Sep 2003 22:48:31 +0000 (+0000)
Subject: r7818: add argument processing using #\=, big refactoring, more tests added and passed
X-Git-Tag: v1.96~124
X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=commitdiff_plain;h=ea87515673ba2fd46e6e1ad270c4abf88d575a19

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

diff --git a/getopt.lisp b/getopt.lisp
index 93f65b6..48ec91b 100644
--- a/getopt.lisp
+++ b/getopt.lisp
@@ -20,7 +20,7 @@
 
 
 (defun is-short-option (arg)
-  (and (= 2 (length arg))
+  (and (>= (length arg) 2)
        (char= #\- (schar arg 0))
        (char/= #\- (schar arg 1))))
 
@@ -35,24 +35,32 @@
        (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
@@ -74,13 +82,29 @@ opts is a list of option lists. The fields of the list are
      ((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)))))))))
 
diff --git a/tests.lisp b/tests.lisp
index 182bddf..08a205d 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -195,7 +195,11 @@
 (deftest gopt.7 (getopt '("ab" "--colon" "val" "--" "-c") '(("colon" :optional) ("-c" :none))) ("ab" "-c") (("colon" . "val")) nil)
 (deftest gopt.8 (getopt '("argv" "-c" "cd") '(("c" :required))) ("argv") (("c" . "cd")) nil)
 (deftest gopt.9 (getopt '("argv" "-c") '(("c" :required))) ("argv") nil ("c"))
-
+(deftest gopt.10 (getopt '("argv" "-c=10") '(("c" :required))) ("argv") (("c" . "10")) nil)
+(deftest gopt.11 (getopt '("argv" "-c=10") '(("c" :none))) ("argv") nil ("c"))
+(deftest gopt.12 (getopt '("--along=10") '(("along" :optional))) nil (("along" . "10")) nil)
+(deftest gopt.13 (getopt '("--along=10") '(("along" :none))) nil nil ("along")) 
+  
 ;;; MOP Testing
 
 (eval-when (:compile-toplevel :load-toplevel :execute)