From d60bf2d464b393bdff8482bcaacd8d49957467ce Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Thu, 11 Sep 2003 16:20:23 +0000
Subject: [PATCH] r7819: more getopt improvements, tests

---
 getopt.lisp  | 17 +++++++++++++----
 package.lisp |  4 ++--
 strings.lisp | 17 +++++++++++++++++
 tests.lisp   | 14 +++++++++++++-
 4 files changed, 45 insertions(+), 7 deletions(-)

diff --git a/getopt.lisp b/getopt.lisp
index 48ec91b..96e5f6f 100644
--- a/getopt.lisp
+++ b/getopt.lisp
@@ -55,12 +55,19 @@
 	  (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)))
+    (when pos
+      (nth pos options))))
+
 (defun match-option (arg options)
   "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))))
+    (let ((match (find-option base-name options)))
+      (values match option-type (when match (car match)) argument))))
 
 (defun getopt (args options)
   "Processes a list of arguments and options. Returns filtered argument
@@ -106,5 +113,7 @@ opts is a list of option lists. The fields of the list are
 			  (push (cons base-name (second pos)) out-opts)
 			  (setq pos (cdr pos))))))))
 	    (t
-	     (push arg out-args)))))))))
+	     (if (in option-type :long :short)
+		 (push (nth-value 0 (arg->base-name arg option-type)) errors)
+		 (push arg out-args))))))))))
 
diff --git a/package.lisp b/package.lisp
index 36d185b..4146122 100644
--- a/package.lisp
+++ b/package.lisp
@@ -67,8 +67,7 @@
    #:string-strip-ending
    #:string-maybe-shorten
    #:shrink-vector
-   
-   #:flatten
+   #:match-unique-abbreviation
 
    ;; io.lisp
    #:indent-spaces
@@ -106,6 +105,7 @@
    #:plist-alist
    #:update-plist
    #:get-plist
+   #:flatten
 
    ;; seq.lisp
    #:nsubseq
diff --git a/strings.lisp b/strings.lisp
index 87d3254..1832ff2 100644
--- a/strings.lisp
+++ b/strings.lisp
@@ -602,3 +602,20 @@ for characters in a string"
         (push (subseq string token-start token-end) tokens)))))
 
 
+(defun match-unique-abbreviation (abbr strings)
+  "Returns position of ABBR in STRINGS. ABBR may be a unique abbreviation.
+Returns NIL if no match found."
+  (let ((len (length abbr))
+	(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))))))
+    (when (= 1 (length matches))
+      (cdr (first matches)))))
diff --git a/tests.lisp b/tests.lisp
index 08a205d..275b9ba 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -186,6 +186,15 @@
 (deftest sse.4 (string-strip-ending "abc" '("ab")) "abc")
 (deftest sse.5 (string-strip-ending "abcd" '("a" "cd")) "ab")
 
+(deftest mua.1 (match-unique-abbreviation "abc" nil) nil)
+(deftest mua.2 (match-unique-abbreviation "abc" '("ab")) nil)
+(deftest mua.3 (match-unique-abbreviation "ab" '("ab")) 0)
+(deftest mua.4 (match-unique-abbreviation "a" '("ab")) 0)
+(deftest mua.5 (match-unique-abbreviation "b" '("ab")) nil)
+(deftest mua.6 (match-unique-abbreviation "ab" '("ab" "abc")) nil)
+(deftest mua.7 (match-unique-abbreviation "ac" '("ab" "ac")) 1)
+(deftest mua.8 (match-unique-abbreviation "ac" '("ab" "acb")) 1)
+
 (deftest gopt.1 (getopt '("argv") nil) ("argv") nil nil)
 (deftest gopt.2 (getopt '("argv" "2") nil) ("argv" "2") nil nil)
 (deftest gopt.3 (getopt '("argv" "-c") '(("c" :none))) ("argv") (("c")) nil)
@@ -199,6 +208,9 @@
 (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")) 
+(deftest gopt.14 (getopt '("--a=10") '(("along" :optional))) nil (("along" . "10")) nil) 
+(deftest gopt.15 (getopt '("--a=10") '(("along" :optional) ("aboot" :optional))) nil nil ("a"))
+	 
   
 ;;; MOP Testing
 
@@ -208,8 +220,8 @@
 
 #+kmrtest-mop
 (progn
-  (setf (find-class 'credit-rating) nil)
   (setf (find-class 'monitored-credit-rating) nil)
+  (setf (find-class 'credit-rating) nil)
   
   (defclass credit-rating ()
     ((level :attributes (date-set time-set))
-- 
2.34.1