src/getopt.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: getopt -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          main.lisp
   6 ;;;; Purpose:       Command line option processing like GNU's getopt_long
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Sep 2003
   9 ;;;;
  10 ;;;; $Id: getopt.lisp,v 1.1 2009-07-13 15:25:24 rtoy Exp $
  11 ;;;;
  12 ;;;; *************************************************************************
  13
  14 ;;;; This file has been modified from the original to support the
  15 ;;;; needs of maxima.  Basically, we changed getopt so that:
  16 ;;;;
  17 ;;;;  - "-ab" is recognized as two separate options: "-a" "-b"
  18 ;;;;
  19 ;;;;  - Exact matches are treated as matches, even if the match is an
  20 ;;;;    ambiguous prefix.  Hence, "--batch" will match the option
  21 ;;;;    "--batch", even though it is an ambiguous prefix for
  22 ;;;;    "--batch-lisp" and "--batch--string".  But "--bat" is still an
  23 ;;;;    error since it is ambiguous and is not an exact match for any
  24 ;;;;    option.
  25 ;;;;
  26 ;;;; To comply with the license, we include the license here:
  27 ;;;;
  28 ;;;; *************************************************************************
  29 ;;;; Copyright (C) 2003 by Kevin M. Rosenberg.
  30 ;;;;
  31 ;;;; All rights reserved.
  32 ;;;;
  33 ;;;; Redistribution and use in source and binary forms, with or without
  34 ;;;; modification, are permitted provided that the following conditions
  35 ;;;; are met:
  36 ;;;; 1. Redistributions of source code must retain the above copyright
  37 ;;;;    notice, this list of conditions and the following disclaimer.
  38 ;;;; 2. Redistributions in binary form must reproduce the above copyright
  39 ;;;;    notice, this list of conditions and the following disclaimer in the
  40 ;;;;    documentation and/or other materials provided with the distribution.
  41 ;;;; 3. Neither the name of the author nor the names of the contributors
  42 ;;;;    may be used to endorse or promote products derived from this software
  43 ;;;;    without specific prior written permission.
  44 ;;;;
  45 ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
  46 ;;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  47 ;;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  48 ;;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
  49 ;;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  50 ;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  51 ;;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  52 ;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  53 ;;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  54 ;;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  55 ;;;; SUCH DAMAGE.
  56 ;;;; *************************************************************************
  57
  58
  59 (in-package #-gcl #:getopt #+gcl "GETOPT")
  60
  61
  62 (defun is-short-option (arg)
  63   (and (>= (length arg) 2)
  64        (char= #\- (schar arg 0))
  65        (char/= #\- (schar arg 1))))
  66
  67 (defun is-option-terminator (arg)
  68   (and (= 2 (length arg))
  69        (char= #\- (schar arg 0))
  70        (char= #\- (schar arg 1))))
  71
  72 (defun is-long-option (arg)
  73   (and (> (length arg) 2)
  74        (char= #\- (schar arg 0))
  75        (char= #\- (schar arg 1))
  76        (char/= #\- (schar arg 2))))
  77
  78 (defun decompose-arg (arg option-type)
  79   "Returns base-name,argument"
  80   (let ((start (ecase option-type
  81                  (:long 2)
  82                  (:short 1)))
  83         (name-end (position #\= arg)))
  84
  85     (values (subseq arg start name-end)
  86             (when name-end (subseq arg (1+ name-end))))))
  87
  88 (defun analyze-arg (arg)
  89   "Analyzes an argument. Returns option-type,base-name,argument"
  90   (let* ((option-type (cond ((is-short-option arg) :short)
  91                             ((is-long-option arg) :long)
  92                             (t :arg))))
  93     (if (or (eq option-type :short) (eq option-type :long))
  94         (multiple-value-bind (base arg) (decompose-arg arg option-type)
  95           (values option-type base arg))
  96         (values :arg arg nil))))
  97
  98
  99 (defun find-option (name options &key allow-exact-match)
 100   "Find an option in option list. Handles using unique abbreviations"
 101   (let* ((option-names (mapcar #'car options))
 102          (pos (match-unique-abbreviation name option-names :allow-exact-match allow-exact-match)))
 103     (when pos
 104       (nth pos options))))
 105
 106 (defun match-option (arg options &key allow-exact-match)
 107   "Matches an argument to an option. Returns option-list,option-type,base-name,argument"
 108   (multiple-value-bind (option-type base-name argument) (analyze-arg arg)
 109     (let ((match (find-option base-name options :allow-exact-match allow-exact-match)))
 110       (values match option-type (when match (car match)) argument))))
 111
 112
 113 ;;; EXPORTED functions
 114
 115 (defun match-unique-abbreviation (abbr strings &key (allow-exact-match nil))
 116   "Returns position of ABBR in STRINGS. ABBR may be a unique abbreviation.
 117 Returns NIL if no match found."
 118   (let ((len (length abbr))
 119         (matches nil))
 120     (dotimes (i (length strings))
 121       (let* ((s (nth i strings))
 122              (l (length s)))
 123         (cond
 124           ((= len l)
 125            (when (string= abbr s)
 126              (if allow-exact-match
 127                  (return-from match-unique-abbreviation i)
 128                  (push (cons s i) matches))))
 129           ((< len l)
 130            (when (string= abbr (subseq s 0 len))
 131              (push (cons s i) matches))))))
 132     (when (= 1 (length matches))
 133       (cdr (first matches)))))
 134
 135 (defun getopt (args options &key allow-exact-match)
 136   "Processes a list of arguments and options. Returns three values:
 137  - Non-option arguments
 138  - An alist of options consisting of the option name and the value, if any
 139  - A list of any option names that were not recognized
 140
 141 options is a list of option lists. The fields of the list are
 142  - NAME name of the long option
 143  - HAS-ARG with legal values of :NONE, :REQUIRED, :OPTIONAL
 144  - VAL value to return for a option with no arguments"
 145   (do ((pos args (cdr pos))
 146        (finished-options)
 147        (out-opts)
 148        (out-args)
 149        (errors))
 150       ((null pos) (values (nreverse out-args) (nreverse out-opts) errors))
 151     (cond
 152      (finished-options
 153       (push (car pos) out-args))
 154      ((is-option-terminator (car pos))
 155       (setq finished-options t))
 156      (t
 157       (let ((arg (car pos)))
 158         (multiple-value-bind (option-list option-type base-name argument)
 159             (match-option (car pos) options :allow-exact-match allow-exact-match)
 160           (cond
 161             ((and option-list (not (eq option-type :arg)))
 162              (cond
 163                (argument
 164                 (case (second option-list)
 165                   (:none
 166                    (push base-name errors))
 167                   (t
 168                    (push (cons base-name argument) out-opts))))
 169                ((null argument)
 170                 (if (and (eq :required (second option-list)) (null (cdr pos)))
 171                     (push base-name errors)
 172                     (case (second option-list)
 173                       (:none
 174                        (push (cons base-name (third option-list)) out-opts))
 175                       (:required
 176                        ;; Next arg is the value.
 177                        (push (cons base-name (second pos)) out-opts)
 178                        (setf pos (cdr pos)))
 179                       (:optional
 180                        ;; Optional arg.  If the next arg is an option
 181                        ;; arg, we use the default value. Otherwise we
 182                        ;; use the next arg as the value.
 183                        (if (or (is-short-option (second pos))
 184                                (is-long-option (second pos)))
 185                            (push (cons base-name (third option-list)) out-opts)
 186                            (progn
 187                              (push (cons base-name (second pos)) out-opts)
 188                              (setf pos (cdr pos))))))))))
 189             (t
 190              (cond ((eq :long option-type)
 191                     (push (nth-value 0 (decompose-arg arg option-type)) errors))
 192                    ((eq :short option-type)
 193                     (cond ((<= (length (car pos)) 2)
 194                            ;; Unrecognized short option (one character)
 195                            (push (nth-value 0 (decompose-arg arg option-type)) errors))
 196                           (t
 197                            ;; We have option that's not matched, but
 198                            ;; looks like a short option like "-abc".
 199                            ;; Expand this to '("-a" "-b" "-c") and
 200                            ;; effectively replace "-abc" with the
 201                            ;; replacement.  We setf the cdr because
 202                            ;; the do loop will remove "-abc" for us.
 203                            (setf (cdr pos)
 204                                  (append (map 'list
 205                                               #'(lambda (x)
 206                                                   (concatenate 'string "-" (string x)))
 207                                               (subseq (car pos) 1))
 208                                          (cdr pos))))))
 209                    (t
 210                     (push arg out-args)))))))))))
 211