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. 117Returns 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 141options 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 212