X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=getopt.lisp;h=48ec91be9a17d362e0dbdb66a26f0e8e6973a961;hb=ea87515673ba2fd46e6e1ad270c4abf88d575a19;hp=ba4cd945c47a579ff0329c9775d2160ccdedf2c9;hpb=904e59aef16b462d7b9a6f1060a9f93ec70e0c4e;p=kmrcl.git

diff --git a/getopt.lisp b/getopt.lisp
index ba4cd94..48ec91b 100644
--- 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)))))))))