cl-getopt-1.2.0/0000755000175000017500000000000010766511753012435 5ustar kevinkevincl-getopt-1.2.0/LICENSE0000644000175000017500000000270710667175445013454 0ustar kevinkevinCopyright (C) 2003 by Kevin M. Rosenberg. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of the contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. cl-getopt-1.2.0/README0000644000175000017500000000056110667175445013323 0ustar kevinkevinLibrary: getopt Author: Kevin Rosenberg URL: http://b9.com/files/getopt/ This package provides a module for analyzing a list of command-line arguments. It uses a command-line syntax similar to the GNU getopt_long function. The package also provides an automated test suite which uses the ptester library from http://b9.com/files/ptester/ cl-getopt-1.2.0/getopt.asd0000644000175000017500000000234310667175445014436 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: getopt-system -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: getopt.asd ;;;; Purpose: ASDF system definition for getopt package ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; ************************************************************************* (in-package cl-user) (defpackage getopt-system (:use #:asdf #:cl)) (in-package getopt-system) (defsystem getopt :name "getopt" :author "Kevin Rosenberg " :version "1.0" :maintainer "Kevin M. Rosenberg " :licence "BSD" :components ((:file "package") (:file "main" :depends-on ("package")))) (defmethod perform ((o test-op) (c (eql (find-system 'getopt)))) (operate 'load-op 'getopt-tests) (operate 'test-op 'getopt-tests :force t)) (defsystem getopt-tests :depends-on (:ptester :getopt) :components ((:file "tests"))) (defmethod perform ((o test-op) (c (eql (find-system 'getopt-tests)))) (or (funcall (intern (symbol-name '#:do-tests) (find-package '#:getopt-tests))) (error "test-op failed"))) cl-getopt-1.2.0/package.lisp0000644000175000017500000000103710667175445014726 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: package.lisp ;;;; Purpose: Package definition for getopt package ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Sep 2003 ;;;; ;;;; $Id$ ;;;; ;;;; ************************************************************************* (in-package cl-user) (defpackage getopt (:use #:cl) (:export #:match-unique-abbreviation #:getopt )) cl-getopt-1.2.0/main.lisp0000644000175000017500000001140310766511421014241 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: getopt -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: main.lisp ;;;; Purpose: Command line option processing like GNU's getopt_long ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Sep 2003 ;;;; ;;;; $Id$ ;;;; ;;;; ************************************************************************* (in-package getopt) (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 2)))) (defun decompose-arg (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) (decompose-arg 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)))) ;;; EXPORTED functions (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))))) (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 ((and option-list (not (eq option-type :arg))) (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 (eq :none (second option-list)) (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-opts)) (progn (push (cons base-name (second pos)) out-opts) (setq pos (cdr pos)))))))) (t (if (or (eq :long option-type) (eq :short option-type)) (push (nth-value 0 (decompose-arg arg option-type)) errors) (push arg out-args)))))))))) cl-getopt-1.2.0/tests.lisp0000644000175000017500000000620410766511421014462 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: getopt-tests -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: getopt-tests.lisp ;;;; Purpose: getopt tests file ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Sep 2003 ;;;; ;;;; $Id$ ;;;; ;;;; This file is Copyright (c) 2003 by Kevin M. Rosenberg ;;;; ;;;; ************************************************************************* (in-package cl) (defpackage getopt-tests (:use #:getopt #:cl #:ptester)) (in-package getopt-tests) (defmacro test-mv (values form) `(test ,values ,form :multiple-values t :test #'equal)) (defun do-tests () (with-tests (:name "GETOPT") (let ((*break-on-test-failures* nil)) ;; match-unique-abbreviation (test nil (match-unique-abbreviation "abc" nil)) (test nil (match-unique-abbreviation "abc" '("ab"))) (test 0 (match-unique-abbreviation "ab" '("ab"))) (test 0 (match-unique-abbreviation "a" '("ab"))) (test nil (match-unique-abbreviation "b" '("ab"))) (test nil (match-unique-abbreviation "ab" '("ab" "abc"))) (test 1 (match-unique-abbreviation "ac" '("ab" "ac"))) (test 1 (match-unique-abbreviation "ac" '("ab" "acb"))) ;; getopt (test-mv '(("argv") nil nil) (getopt '("argv") nil)) (test-mv '(("argv" "2") nil nil) (getopt '("argv" "2") nil)) (test-mv '(("argv") (("c")) nil) (getopt '("argv" "-c") '(("c" :none)))) (test-mv '(("argv") (("c" . "val")) nil) (getopt '("argv" "-c" "val") '(("c" :optional)))) (test-mv '(("argv" "v1") (("c" . "val")) nil) (getopt '("argv" "-c" "val" "v1") '(("c" :optional)))) (test-mv '(( "v1") (("colon" . "val")) nil) (getopt '("--colon" "val" "v1") '(("colon" :optional)))) (test-mv '(("ab" "-c") (("colon" . "val")) nil) (getopt '("ab" "--colon" "val" "--" "-c") '(("colon" :optional) ("-c" :none)))) (test-mv '(("argv") (("c" . "cd")) nil) (getopt '("argv" "-c" "cd") '(("c" :required)))) (test-mv '(("argv") nil ("c")) (getopt '("argv" "-c") '(("c" :required)))) (test-mv '(("argv") (("c" . "10")) nil) (getopt '("argv" "-c=10") '(("c" :required)))) (test-mv '(("argv") nil ("c")) (getopt '("argv" "-c=10") '(("c" :none)))) (test-mv '(nil (("along" . "10")) nil) (getopt '("--along=10") '(("along" :optional)))) (test-mv '(nil nil ("along")) (getopt '("--along=10") '(("along" :none)))) (test-mv '(nil (("along" . "10")) nil) (getopt '("--a=10") '(("along" :optional)))) (test-mv '(nil nil ("a")) (getopt '("--a=10") '(("along" :optional) ("aboot" :optional)))) (test-mv '(("a") nil nil) (getopt '("a") '(("a" :none)))) (test-mv '(("a") (("foo") ("bar")) nil) (getopt '("a" "--foo" "--bar") '(("foo" :none) ("bar" :none)))) (test-mv '(("a") (("foo") ("bar")) nil) (getopt '("a" "--f" "--bar") '(("foo" :none) ("bar" :none)))) )) t)