getopt.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          getopt.lisp
   6 ;;;; Purpose:       Command line option processing a la GNU getopt_long
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Sep 2003
   9 ;;;;
  10 ;;;; $Id: package.lisp 7814 2003-09-10 12:56:02Z kevin $
  11 ;;;;
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; KMRCL users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19 (in-package #:kmr)
  20
  21
  22 (defun is-short-option (arg)
  23   (and (= 2 (length arg))
  24        (char= #\- (schar arg 0))
  25        (char/= #\- (schar arg 1))))
  26
  27 (defun is-option-terminator (arg)
  28   (and (= 2 (length arg))
  29        (char= #\- (schar arg 0))
  30        (char= #\- (schar arg 1))))
  31
  32 (defun is-long-option (arg)
  33   (and (> (length arg 2))
  34        (char= #- (schar 0))
  35        (char= #- (schar 1))
  36        (char/= #- (schar 3))))
  37
  38 (defun match-option (arg options)
  39   "Matches an argument to an option. Returns match,is-long"
  40   (cond
  41     ((is-long-option arg)
  42      (values (find (subseq arg 2) options :key #'car :test #'equal) :long))
  43     ((is-short-option arg)
  44      (values (find (subseq arg 1) options :key #'car :test #'equal) :short))
  45     (t
  46      (values nil nil))))
  47
  48 (defun getopt (args opts)
  49   "Processes a list of arguments and options. Returns filtered argument
  50 list and alist of options.
  51 opts is a list of option lists. The fields of the list are
  52  - NAME name of the long option
  53  - HAS-ARG with legal values of :NONE, :REQUIRED, :OPTIONAL
  54  - VAL value to return for a option with no arguments
  55 "
  56   (do ((pos args)
  57        (out-opts)
  58        (out-args)
  59        (errors))
  60       ((null pos) (values out-args out-opts errors))
  61     (multiple-value-bind (match is-long) (match-option (car pos) options))
  62       (if match
  63           (progn
  64             (push (cons (car pos) (second pos)) out-opts)
  65             (setq pos (cddr pos))))))
  66