r7819: more getopt improvements, tests

diff --git a/getopt.lisp b/getopt.lisp
index 48ec91be9a17d362e0dbdb66a26f0e8e6973a961..96e5f6fa46e2ba300a455b3224394344862bff89 100644 (file)
--- 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 36d185bf21c4d60e2e7b65588b3261dcbddcdbac..4146122e8adf15343538b0725a3bf8ff1035e5bd 100644 (file)
--- 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 87d325425c8e7902b9ea06542952e31836aa408e..1832ff2a5dfa58f94564ee87f7b59587527c7b6e 100644 (file)
--- 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 08a205da30691231b29a0c7be677f9d796e8502a..275b9ba0bff9680c4b9f1401e10f68ef36dca07d 100644 (file)
--- 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))