From 2cfe7dc5fb016ef08bb70e3eabed39c44dad468a Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Wed, 10 Sep 2003 18:38:33 +0000
Subject: [PATCH] r7817: first working version, add getopt to test suite

---
 getopt.lisp  | 46 +++++++++++++++++++++++++++++++++-------------
 kmrcl.asd    |  3 ++-
 package.lisp |  3 +++
 tests.lisp   | 12 +++++++++++-
 4 files changed, 49 insertions(+), 15 deletions(-)

diff --git a/getopt.lisp b/getopt.lisp
index ba4cd94..93f65b6 100644
--- a/getopt.lisp
+++ b/getopt.lisp
@@ -16,7 +16,7 @@
 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 
-(in-package #:kmr)
+(in-package #:kmrcl)
 
 
 (defun is-short-option (arg)
@@ -30,11 +30,20 @@
        (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)
+  (cond
+   ((is-long-option arg)
+    (subseq arg 2))
+   ((is-short-option arg)
+    (subseq arg 1))
+   (t
+    arg)))
+  
 (defun match-option (arg options)
   "Matches an argument to an option. Returns match,is-long"
   (cond
@@ -45,7 +54,7 @@
     (t
      (values nil nil))))
 
-(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 +62,25 @@ 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
+      (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)))))))
 
diff --git a/kmrcl.asd b/kmrcl.asd
index c63818b..96f862b 100644
--- a/kmrcl.asd
+++ b/kmrcl.asd
@@ -58,9 +58,10 @@
      (:file "listener" :depends-on ("sockets" "processes" "console"))
      (:file "repl" :depends-on ("listener" "strings"))
      (:file "os" :depends-on ("macros"))
+     (:file "getopt" :depends-on ("macros"))
      ))
 
 (defmethod perform ((o test-op) (c (eql (find-system 'kmrcl))))
   (operate 'load-op 'kmrcl-tests)
-  (operate 'test-op 'kmrcl-tests))
+  (operate 'test-op 'kmrcl-tests :force t))
 
diff --git a/package.lisp b/package.lisp
index 63198e7..36d185b 100644
--- a/package.lisp
+++ b/package.lisp
@@ -243,6 +243,9 @@
 
    ;; os.lisp
    #:run-shell-command
+
+   ;; getopt.lisp
+   #:getopt
    
    ))
 
diff --git a/tests.lisp b/tests.lisp
index 9fe72f4..182bddf 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -1,4 +1,4 @@
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: kmrcl-tests -*-
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
@@ -186,6 +186,16 @@
 (deftest sse.4 (string-strip-ending "abc" '("ab")) "abc")
 (deftest sse.5 (string-strip-ending "abcd" '("a" "cd")) "ab")
 
+(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)
+(deftest gopt.4 (getopt '("argv" "-c" "val") '(("c" :optional))) ("argv") (("c" . "val")) nil)
+(deftest gopt.5 (getopt '("argv" "-c" "val" "v1") '(("c" :optional))) ("argv" "v1") (("c" . "val")) nil)
+(deftest gopt.6 (getopt '("--colon" "val" "v1") '(("colon" :optional))) ( "v1") (("colon" . "val")) nil)
+(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"))
+
 ;;; MOP Testing
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-- 
2.34.1