;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package #:kmr)
+(in-package #:kmrcl)
(defun is-short-option (arg)
(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
(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
- 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)))))))
(: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))
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: kmrcl-tests -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
(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)