X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=getopt.lisp;h=96e5f6fa46e2ba300a455b3224394344862bff89;hb=d60bf2d464b393bdff8482bcaacd8d49957467ce;hp=93f65b645e4cdf8023c5a43efcd13aff92692b76;hpb=2cfe7dc5fb016ef08bb70e3eabed39c44dad468a;p=kmrcl.git

diff --git a/getopt.lisp b/getopt.lisp
index 93f65b6..96e5f6f 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,39 @@
        (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 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 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-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
@@ -74,13 +89,31 @@ 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
+	     (if (in option-type :long :short)
+		 (push (nth-value 0 (arg->base-name arg option-type)) errors)
+		 (push arg out-args))))))))))