From: Kevin M. Rosenberg Date: Fri, 12 Sep 2003 16:49:49 +0000 (+0000) Subject: r7827: initial version,import X-Git-Tag: debian-1.1.0-3~9 X-Git-Url: http://git.kpe.io/?p=getopt.git;a=commitdiff_plain;h=6f02e1d3632a72a98c66def70d68ea2d4020e227 r7827: initial version,import --- 6f02e1d3632a72a98c66def70d68ea2d4020e227 diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..ac0d70a --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (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. diff --git a/README b/README new file mode 100644 index 0000000..0f0d2e6 --- /dev/null +++ b/README @@ -0,0 +1,10 @@ +Library: 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/ + + diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..603d64c --- /dev/null +++ b/debian/changelog @@ -0,0 +1,5 @@ +cl-getopt (1.0-1) unstable; urgency=low + + * Initial upload + + -- Kevin M. Rosenberg Thu, 11 Sep 2003 19:35:18 -0600 diff --git a/debian/compat b/debian/compat new file mode 100644 index 0000000..b8626c4 --- /dev/null +++ b/debian/compat @@ -0,0 +1 @@ +4 diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..4278f16 --- /dev/null +++ b/debian/control @@ -0,0 +1,14 @@ +Source: cl-getopt +Section: devel +Priority: optional +Maintainer: Kevin M. Rosenberg +Build-Depends-Indep: debhelper (>= 4.0.0) +Standards-Version: 3.6.1.0 + +Package: cl-getopt +Architecture: all +Depends: ${shlibs:Depends}, common-lisp-controller, cl-ptester +Description: Common Lisp utility for command-line processing + This package provides Common Lisp programs processing of command-line + arguments. The command-line processing is based on GNU's getopt_long + module. diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..299b8ac --- /dev/null +++ b/debian/copyright @@ -0,0 +1,34 @@ +This package was debianized by Kevin M. Rosenberg in +Sat, 5 Oct 2002 13:19:33 -0600. + +It was downloaded from ftp://ftp.b9.com/getopt + +Upstream Author: Kevin M. Rosenberg + +Copyright (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. diff --git a/debian/docs b/debian/docs new file mode 100644 index 0000000..e845566 --- /dev/null +++ b/debian/docs @@ -0,0 +1 @@ +README diff --git a/debian/postinst b/debian/postinst new file mode 100755 index 0000000..b17dbde --- /dev/null +++ b/debian/postinst @@ -0,0 +1,41 @@ +#! /bin/sh +set -e + +LISP_PKG=getopt + +# summary of how this script can be called: +# * `configure' +# * `abort-upgrade' +# * `abort-remove' `in-favour' +# +# * `abort-deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package +# +# quoting from the policy: +# Any necessary prompting should almost always be confined to the +# post-installation script, and should be protected with a conditional +# so that unnecessary prompting doesn't happen if a package's +# installation fails and the `postinst' is called with `abort-upgrade', +# `abort-remove' or `abort-deconfigure'. + +case "$1" in + configure) + /usr/sbin/register-common-lisp-source ${LISP_PKG} + ;; + abort-upgrade|abort-remove|abort-deconfigure) + ;; + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 diff --git a/debian/prerm b/debian/prerm new file mode 100755 index 0000000..e711eee --- /dev/null +++ b/debian/prerm @@ -0,0 +1,37 @@ +#! /bin/sh +set -e + +LISP_PKG=getopt + +# summary of how this script can be called: +# * `remove' +# * `upgrade' +# * `failed-upgrade' +# * `remove' `in-favour' +# * `deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package + + +case "$1" in + remove|upgrade|deconfigure) + /usr/sbin/unregister-common-lisp-source ${LISP_PKG} + ;; + failed-upgrade) + ;; + *) + echo "prerm called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..2c45968 --- /dev/null +++ b/debian/rules @@ -0,0 +1,80 @@ +#!/usr/bin/make -f + +pkg := getopt +debpkg := cl-$(pkg) + +clc-source := usr/share/common-lisp/source +clc-systems := usr/share/common-lisp/systems +clc-files := $(clc-source)/$(pkg) +clc-tests := $(clc-source)/$(pkg-tests) +doc-dir := usr/share/doc/$(debpkg) + +source-files := $(wildcard *.lisp) + +configure: configure-stamp +configure-stamp: + dh_testdir + # Add here commands to configure the package. + + touch configure-stamp + + +build: build-stamp + +build-stamp: configure-stamp + dh_testdir + # Add here commands to compile the package. + touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp configure-stamp + # Add here commands to clean up after the build process. + rm -f debian/$(debpkg).postinst.* debian/$(debpkg).prerm.* + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + # Add here commands to install the package into debian/getopt. + dh_installdirs $(clc-systems) $(clc-files) $(clc-tests) + dh_install $(pkg).asd $(source-files) $(clc-files) + dh_link $(clc-files)/$(pkg).asd $(clc-systems)/$(pkg).asd + +# Build architecture-independent files here. +binary-indep: build install + + +# Build architecture-dependent files here. +binary-arch: build install + dh_testdir + dh_testroot +# dh_installdebconf + dh_installdocs +# dh_installmenu +# dh_installlogrotate +# dh_installemacsen +# dh_installpam +# dh_installmime +# dh_installinit +# dh_installcron +# dh_installman +# dh_installinfo +# dh_undocumented + dh_installchangelogs + dh_strip + dh_compress + dh_fixperms +# dh_makeshlibs + dh_installdeb +# dh_perl + dh_shlibdeps + dh_gencontrol + dh_md5sums + dh_builddeb + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install configure + diff --git a/debian/upload.sh b/debian/upload.sh new file mode 100755 index 0000000..1e285d3 --- /dev/null +++ b/debian/upload.sh @@ -0,0 +1,6 @@ +#!/bin/bash -e + +dup getopt -Uftp.med-info.com -D/home/ftp/getopt -C"(cd /opt/apache/htdocs/getopt; make install)" -su $* + + + diff --git a/getopt.asd b/getopt.asd new file mode 100644 index 0000000..8174069 --- /dev/null +++ b/getopt.asd @@ -0,0 +1,44 @@ +;;;; -*- 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: kmrcl.asd 7817 2003-09-10 18:38:33Z kevin $ +;;;; +;;;; ************************************************************************* + +(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"))) + diff --git a/main.lisp b/main.lisp new file mode 100644 index 0000000..e348f42 --- /dev/null +++ b/main.lisp @@ -0,0 +1,136 @@ +;;;; -*- 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: package.lisp 7814 2003-09-10 12:56:02Z kevin $ +;;;; +;;;; ************************************************************************* + +(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 3)))) + +(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 + (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 (or (eq :long option-type) + (eq :short option-type)) + (push (nth-value 0 (decompose-arg arg option-type)) errors) + (push arg out-args)))))))))) + diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..618ac61 --- /dev/null +++ b/package.lisp @@ -0,0 +1,21 @@ +;;;; -*- 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: package.lisp 7819 2003-09-11 16:20:23Z kevin $ +;;;; +;;;; ************************************************************************* + +(in-package cl-user) + +(defpackage getopt + (:use #:cl) + (:export + #:match-unique-abbreviation + #:getopt + )) diff --git a/tests.lisp b/tests.lisp new file mode 100644 index 0000000..d863b6f --- /dev/null +++ b/tests.lisp @@ -0,0 +1,70 @@ +;;;; -*- 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: tests.lisp 7819 2003-09-11 16:20:23Z kevin $ +;;;; +;;;; 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)))) + )) + t)