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 #:kmrcl)
  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 arg 0))
  35        (char= #\- (schar arg 1))
  36        (char/= #\- (schar arg 3))))
  37
  38 (defun arg->base-name (arg)
  39   (cond
  40    ((is-long-option arg)
  41     (subseq arg 2))
  42    ((is-short-option arg)
  43     (subseq arg 1))
  44    (t
  45     arg)))
  46
  47 (defun match-option (arg options)
  48   "Matches an argument to an option. Returns match,is-long"
  49   (cond
  50     ((is-long-option arg)
  51      (values (find (subseq arg 2) options :key #'car :test #'equal) :long))
  52     ((is-short-option arg)
  53      (values (find (subseq arg 1) options :key #'car :test #'equal) :short))
  54     (t
  55      (values nil nil))))
  56
  57 (defun getopt (args options)
  58   "Processes a list of arguments and options. Returns filtered argument
  59 list and alist of options.
  60 opts is a list of option lists. The fields of the list are
  61  - NAME name of the long option
  62  - HAS-ARG with legal values of :NONE, :REQUIRED, :OPTIONAL
  63  - VAL value to return for a option with no arguments
  64 "
  65   (do ((pos args (cdr pos))
  66        (finished-options)
  67        (out-opts)
  68        (out-args)
  69        (errors))
  70       ((null pos) (values (nreverse out-args) (nreverse out-opts) errors))
  71     (cond
  72      (finished-options
  73       (push (car pos) out-args))
  74      ((is-option-terminator (car pos))
  75       (setq finished-options t))
  76      (t
  77       (multiple-value-bind (match is-long) (match-option (car pos) options)
  78         (if match
  79             (cond
  80              ((and (eq :required (second match)) (null (cdr pos)))
  81               (push  (arg->base-name (car pos)) errors))
  82              (t
  83               (push (cons (arg->base-name (car pos)) (second pos)) out-opts)
  84               (setq pos (cdr pos))))
  85           (push (car pos) out-args)))))))
  86