--- /dev/null
+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.
--- /dev/null
+Library: getopt
+Author: Kevin Rosenberg <kevin@rosenberg.net>
+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/
+
+
--- /dev/null
+cl-getopt (1.0-1) unstable; urgency=low
+
+ * Initial upload
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Thu, 11 Sep 2003 19:35:18 -0600
--- /dev/null
+Source: cl-getopt
+Section: devel
+Priority: optional
+Maintainer: Kevin M. Rosenberg <kmr@debian.org>
+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.
--- /dev/null
+This package was debianized by Kevin M. Rosenberg <kmr@debian.org> in
+Sat, 5 Oct 2002 13:19:33 -0600.
+
+It was downloaded from ftp://ftp.b9.com/getopt
+
+Upstream Author: Kevin M. Rosenberg <kevin@rosenberg.net>
+
+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.
--- /dev/null
+#! /bin/sh
+set -e
+
+LISP_PKG=getopt
+
+# summary of how this script can be called:
+# * <postinst> `configure' <most-recently-configured-version>
+# * <old-postinst> `abort-upgrade' <new version>
+# * <conflictor's-postinst> `abort-remove' `in-favour' <package>
+# <new-version>
+# * <deconfigured's-postinst> `abort-deconfigure' `in-favour'
+# <failed-install-package> <version> `removing'
+# <conflicting-package> <version>
+# 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
--- /dev/null
+#! /bin/sh
+set -e
+
+LISP_PKG=getopt
+
+# summary of how this script can be called:
+# * <prerm> `remove'
+# * <old-prerm> `upgrade' <new-version>
+# * <new-prerm> `failed-upgrade' <old-version>
+# * <conflictor's-prerm> `remove' `in-favour' <package> <new-version>
+# * <deconfigured's-prerm> `deconfigure' `in-favour'
+# <package-being-installed> <version> `removing'
+# <conflicting-package> <version>
+# 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
+
+
--- /dev/null
+#!/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
+
--- /dev/null
+#!/bin/bash -e
+
+dup getopt -Uftp.med-info.com -D/home/ftp/getopt -C"(cd /opt/apache/htdocs/getopt; make install)" -su $*
+
+
+
--- /dev/null
+;;;; -*- 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 <kevin@rosenberg.net>"
+ :version "1.0"
+ :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
+ :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")))
+
--- /dev/null
+;;;; -*- 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))))))))))
+
--- /dev/null
+;;;; -*- 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
+ ))
--- /dev/null
+;;;; -*- 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)
projects / getopt.git / commitdiff