From 7367c68a5daa2ef45c7adf1f4097596f84f5e4dd Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 12 Sep 2003 17:28:26 +0000 Subject: [PATCH] r7834: remove getopt from package --- getopt.lisp | 119 --------------------------------------------------- kmrcl.asd | 1 - package.lisp | 4 -- strings.lisp | 18 +------- tests.lisp | 25 ----------- 5 files changed, 1 insertion(+), 166 deletions(-) delete mode 100644 getopt.lisp diff --git a/getopt.lisp b/getopt.lisp deleted file mode 100644 index 96e5f6f..0000000 --- a/getopt.lisp +++ /dev/null @@ -1,119 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: getopt.lisp -;;;; Purpose: Command line option processing a la GNU getopt_long -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Sep 2003 -;;;; -;;;; $Id: package.lisp 7814 2003-09-10 12:56:02Z kevin $ -;;;; -;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; KMRCL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(in-package #:kmrcl) - - -(defun is-short-option (arg) - (and (>= (length arg) 2) - (char= #\- (schar arg 0)) - (char/= #\- (schar arg 1)))) - -(defun is-option-terminator (arg) - (and (= 2 (length arg)) - (char= #\- (schar arg 0)) - (char= #\- (schar arg 1)))) - -(defun is-long-option (arg) - (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 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-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 -list and alist of options. -opts is a list of option lists. The fields of the list are - - NAME name of the long option - - HAS-ARG with legal values of :NONE, :REQUIRED, :OPTIONAL - - VAL value to return for a option with no arguments -" - (do ((pos args (cdr pos)) - (finished-options) - (out-opts) - (out-args) - (errors)) - ((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 - (if (in option-type :long :short) - (push (nth-value 0 (arg->base-name arg option-type)) errors) - (push arg out-args)))))))))) - diff --git a/kmrcl.asd b/kmrcl.asd index 96f862b..fa29802 100644 --- a/kmrcl.asd +++ b/kmrcl.asd @@ -58,7 +58,6 @@ (: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)))) diff --git a/package.lisp b/package.lisp index 4146122..fb555be 100644 --- a/package.lisp +++ b/package.lisp @@ -67,7 +67,6 @@ #:string-strip-ending #:string-maybe-shorten #:shrink-vector - #:match-unique-abbreviation ;; io.lisp #:indent-spaces @@ -244,9 +243,6 @@ ;; os.lisp #:run-shell-command - ;; getopt.lisp - #:getopt - )) diff --git a/strings.lisp b/strings.lisp index 1832ff2..fd2f37c 100644 --- a/strings.lisp +++ b/strings.lisp @@ -602,20 +602,4 @@ 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 275b9ba..fc950e4 100644 --- a/tests.lisp +++ b/tests.lisp @@ -186,31 +186,6 @@ (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) -(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")) -(deftest gopt.10 (getopt '("argv" "-c=10") '(("c" :required))) ("argv") (("c" . "10")) nil) -(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 -- 2.34.1