├── .gitignore ├── pkgdcl.lisp ├── LICENSE ├── TODO ├── command-line-arguments.asd ├── help.lisp ├── test.lisp ├── argv.lisp ├── README.md └── parse.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.*f*sl 2 | -------------------------------------------------------------------------------- /pkgdcl.lisp: -------------------------------------------------------------------------------- 1 | #+xcvb (module ()) 2 | 3 | (cl:defpackage :command-line-arguments 4 | (:use :cl :uiop) 5 | (:export 6 | #:*command-line-arguments* 7 | #:*command-line-options* 8 | #:*command-line-option-specification* 9 | #:process-command-line-options 10 | #:compute-and-process-command-line-options 11 | #:get-command-line-arguments 12 | #:handle-command-line 13 | #:show-option-help 14 | #:define-command 15 | #:command-line-arity 16 | )) 17 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2008-2009 ITA Software, Inc. 2 | 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | TODO 2 | 3 | * Migrate to CLON? 4 | Not until Didier Verna 5 | (1) merges our patch to split the core from the rest of CLON, and 6 | (2) implements a way to directly call a function with the required arguments. 7 | 8 | * add documentation besides the comments in the code. 9 | 10 | * add counter variables for verbosity flags: 11 | -v -v -v adds 3 to the default value. 12 | With minimum and maximum value caps in the finalizer. 13 | 14 | * enhance layout of self-documentation 15 | Have an automatic layout strategy for self-documentation. 16 | Maybe output the kind of things that man(1) expects, groff(7), 17 | then actually integrate with the man system. 18 | Or else, build a general tool to display stuff on a terminal 19 | while respecting terminal width. 20 | Or output HTML and use lynx -dump or a browser. 21 | 22 | * BUG: Apparently, when there is a missing string argument to a string option 23 | as in --string --bar we assign T to string argument --string instead of erroring out. 24 | 25 | * Have an actual test suite. Sigh. 26 | 27 | * Similar bug to fix, keeping a regression test: 28 | (process-command-line-options '(("export-model" :type boolean :optional nil)) '("--export-model" "no")) 29 | 30 | * Use the equivalent of UIOP 3.1.4.5's standard-case-symbol-name instead of string-upcase; 31 | when the UIOP has settled in, use UIOP's version instead. 32 | -------------------------------------------------------------------------------- /command-line-arguments.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: lisp -*- 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;;; ;;; 4 | ;;; Free Software available under an MIT-style license. See LICENSE ;;; 5 | ;;; ;;; 6 | ;;; Copyright (c) 2008 ITA Software, Inc. All rights reserved. ;;; 7 | ;;; ;;; 8 | ;;; Original authors: Francois-Rene Rideau ;;; 9 | ;;; ;;; 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | 12 | (defsystem "command-line-arguments" 13 | :author ("Francois-Rene Rideau") 14 | :maintainer "Eric Schulte" 15 | :licence "MIT" 16 | :description "small library to deal with command-line arguments" 17 | :long-description "A library to abstract away the parsing of Unix-style command-line arguments" 18 | :version "2.0.0" 19 | :depends-on (#-asdf3 :uiop) 20 | :components 21 | ((:file "pkgdcl") 22 | (:file "argv" :depends-on ("pkgdcl")) 23 | (:file "parse" :depends-on ("pkgdcl")) 24 | (:file "help" :depends-on ("pkgdcl"))) 25 | :in-order-to ((test-op (test-op command-line-arguments/test)))) 26 | 27 | (defsystem "command-line-arguments/test" 28 | :depends-on (:command-line-arguments :alexandria :hu.dwim.stefil) 29 | :components ((:file "test")) 30 | :perform (test-op (o c) (call-function "command-line-arguments/test::test-suite"))) 31 | -------------------------------------------------------------------------------- /help.lisp: -------------------------------------------------------------------------------- 1 | #+xcvb (module (:depends-on ("pkgdcl"))) 2 | 3 | (in-package :command-line-arguments) 4 | 5 | (defun split-sequence (sequence delimiter) 6 | (loop 7 | :with index = 0 8 | :for match = (position delimiter sequence :start index) 9 | :when (and match 10 | (not (= index match))) 11 | :collect (subseq sequence index match) 12 | :when match 13 | :do (setf index (1+ match)) 14 | :unless (or match 15 | (= index (length sequence))) 16 | :collect (subseq sequence index) 17 | :while match)) 18 | 19 | (defun show-option-help (specification &key (stream *standard-output*) sort-names docstring) 20 | ;; TODO: be clever when trying to align stuff horizontally 21 | (loop :with *print-right-margin* = (max (or *print-right-margin* 0) 100) 22 | :for spec :in specification :do 23 | (destructuring-bind (names &key negation documentation negation-documentation 24 | type optional list (initial-value nil initial-value-p) &allow-other-keys) spec 25 | (declare (ignorable negation documentation negation-documentation type optional list)) 26 | (unless (consp names) 27 | (setf names (list names))) 28 | (flet ((option-names (names) 29 | (let ((n (mapcar 'option-name names))) 30 | (if sort-names 31 | (stable-sort n #'< :key #'length) 32 | n)))) 33 | (when documentation 34 | (format stream 35 | (if docstring 36 | "~&* ~:@(~A~) (~A) ~@<~@;~{~A~^ ~}~@:>" 37 | "~& ~32A ~8A ~@<~@;~{~A~^ ~}~@:>") 38 | (if docstring 39 | (car names) 40 | (format nil "~{ ~A~}" (option-names names))) 41 | (string-downcase type) 42 | (split-sequence documentation #\Space)) 43 | (format stream "~:[~*~; (default: ~S)~]~%" initial-value-p initial-value)) 44 | (when negation-documentation 45 | (format stream " ~32A ~8A ~@<~@;~{~A~^ ~}~@:>~%" 46 | (format nil "~{ ~A~}" (option-names (make-negated-names names negation))) 47 | (string-downcase type) 48 | (split-sequence negation-documentation #\Space))))))) 49 | -------------------------------------------------------------------------------- /test.lisp: -------------------------------------------------------------------------------- 1 | #+xcvb (module (:depends-on ("asdf-encodings" (:asdf "hu.dwim.stefil")))) 2 | 3 | (defpackage :command-line-arguments/test 4 | (:use :cl :command-line-arguments :alexandria :hu.dwim.stefil)) 5 | 6 | (in-package :command-line-arguments/test) 7 | 8 | ;;; Testing the asdf-encodings library. 9 | 10 | (defsuite* (test-suite 11 | :in root-suite 12 | :documentation "Testing command-line-arguments")) 13 | 14 | (defparameter *opt-spec* 15 | '((("all" #\a) :type boolean :documentation "do it all") 16 | ("blah" :type string :initial-value "blob" :documentation "This is a very long multi line documentation. The function SHOW-OPTION-HELP should display this properly indented, that is all lines should start at the same column.") 17 | (("verbose" #\v) :type boolean :documentation "include debugging output") 18 | (("file" #\f) :type string :documentation "read from file instead of standard input") 19 | (("xml-port" #\x) :type integer :optional t :documentation "specify port for an XML listener") 20 | (("http-port" #\h) :type integer :initial-value 80 :documentation "specify port for an HTTP listener") 21 | ("enable-cache" :type boolean :documentation "enable cache for queries") 22 | ("path" :type string :list t :optional t :documentation "add given directory to the path") 23 | ("port" :type integer :list (:initial-contents (1 2)) :optional t :documentation "add a normal listen on given port"))) 24 | 25 | (deftest test-process-command-line-options () 26 | (multiple-value-bind (options arguments) 27 | (process-command-line-options 28 | *opt-spec* 29 | '("--all" "--no-verbose" "--file" "foo" "-f" "-v" "-v" 30 | "-x" "--disable-cache" "-h" "8080" 31 | "--no-port" "--port" "3" "--port=4" 32 | "--path" "/foo" "--path" "/bar" 33 | "--" "--foo" "bar" "baz")) 34 | (is (equal arguments '("--foo" "bar" "baz"))) 35 | (is (equal (sort (alexandria:plist-alist options) 'string< :key 'car) 36 | '((:all . t) (:blah . "blob") (:enable-cache) (:file . "-v") (:file . "foo") 37 | (:http-port . 8080) (:http-port . 80) (:path "/foo" "/bar") (:port 3 4) 38 | (:verbose . t) (:verbose) (:xml-port . t))))) 39 | nil) 40 | 41 | (deftest test-show-option-help () 42 | (is (with-output-to-string (s) (show-option-help *opt-spec* :stream s)) 43 | " --all -a boolean do it all 44 | --blah string This is a very long multi line documentation. The 45 | function SHOW-OPTION-HELP should display this properly 46 | indented, that is all lines should start at the same 47 | column. (default: \"blob\") 48 | --verbose -v boolean include debugging output 49 | --file -f string read from file instead of standard input 50 | --xml-port -x integer specify port for an XML listener 51 | --http-port -h integer specify port for an HTTP listener (default: 80) 52 | --enable-cache boolean enable cache for queries 53 | --path string add given directory to the path 54 | --port integer add a normal listen on given port 55 | 56 | ") 57 | nil) 58 | 59 | -------------------------------------------------------------------------------- /argv.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;; ;;; 3 | ;;; Free Software available under an MIT-style license. See LICENSE ;;; 4 | ;;; ;;; 5 | ;;; Copyright (c) 2009 ITA Software, Inc. All rights reserved. ;;; 6 | ;;; ;;; 7 | ;;; Original author: Francois-Rene Rideau ;;; 8 | ;;; ;;; 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | #+xcvb (module (:depends-on ("pkgdcl"))) 12 | 13 | (in-package :command-line-arguments) 14 | 15 | (declaim (ftype (function (t t) (values t t)) process-command-line-options)) 16 | 17 | (defun get-command-line-arguments () 18 | uiop:*command-line-arguments*) 19 | 20 | (defun compute-and-process-command-line-options (specification) 21 | (process-command-line-options specification (get-command-line-arguments))) 22 | 23 | (define-condition command-line-arity (error) 24 | ((name :initarg :name :reader name) 25 | (arguments :initarg :arguments :reader arguments) 26 | (rest-arity :initarg :rest-arity :reader rest-arity) 27 | (positional-arity :initarg :positional-arity :reader positional-arity)) 28 | (:report 29 | (lambda (condition stream) 30 | (with-slots (name arguments rest-arity positional-arity) condition 31 | (if (< (length arguments) positional-arity) 32 | (format stream "~@[~A: ~] Too few arguments. Expected~@[ at least~] ~A, got ~A ~S" 33 | name rest-arity positional-arity (length arguments) arguments) 34 | (format stream "~@[~A: ~] Too many arguments. Expected only ~A, got ~A ~S" 35 | name positional-arity (length arguments) arguments))))) 36 | (:documentation 37 | "Indicates the wrong number of arguments were given on the command line.")) 38 | 39 | (defun invoke-command-line-handler (function options arguments &key 40 | (positional-arity 0) (rest-arity nil) name) 41 | (let ((l (length arguments))) 42 | (when (or (< l positional-arity) 43 | (and (> l positional-arity) (not rest-arity))) 44 | (error (make-condition 'command-line-arity 45 | :name name 46 | :arguments arguments 47 | :rest-arity rest-arity 48 | :positional-arity positional-arity)))) 49 | (let ((positional-arguments (subseq arguments 0 positional-arity)) 50 | (rest-arguments (when rest-arity (subseq arguments positional-arity)))) 51 | (apply function (append positional-arguments 52 | (etypecase rest-arity 53 | (null nil) 54 | ((eql t) (list rest-arguments)) 55 | (keyword (list rest-arity rest-arguments))) 56 | options)))) 57 | 58 | (defun handle-command-line (specification function 59 | &key (positional-arity 0) (rest-arity nil) name 60 | (command-line (get-command-line-arguments))) 61 | (multiple-value-bind (options arguments) 62 | (process-command-line-options specification command-line) 63 | (invoke-command-line-handler function options arguments 64 | :name name 65 | :positional-arity positional-arity 66 | :rest-arity rest-arity))) 67 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | command-line-arguments 2 | ====================== 3 | 4 | A library for parsing command-line arguments. 5 | 6 | Use it in conjunction with [asdf:program-op](https://common-lisp.net/project/asdf/) or 7 | [cl-launch](http://cliki.net/cl-launch) for portable processing of command-line arguments. 8 | 9 | 10 | Usage 11 | ----- 12 | 13 | This library is woefully under-documented. 14 | See the examples below, and read [the source code](parse.lisp) for details. 15 | Here is what a prototypical use looks like: 16 | 17 | (defparameter +command-line-spec+ 18 | '(((#\b) :type boolean :optional t :documentation "what optional -b flag does") 19 | (("check" #\c) :type string :optional t :documentation "a --check or -c flag that takes a string") 20 | (("verbose") :type boolean :optional t :documentation "only a verbose --verbose is accepted") 21 | (("warn" "warning" #\w) :type boolean :optional t :documentation "multiple spellings possible") 22 | (("help" #\h #\?) :type boolean :optional t :documentation "--help -h -?, good practice to have") 23 | (("version" #\V) :type boolean :optional t :documentation "--version or -V, you get the idea"))) 24 | 25 | ;; for the positional arguments, see below :positional-arity and :rest-arity 26 | (defun my-program-function (arg1 arg2 rest-args &key b check verbose warn help version) 27 | (when help (show-option-help +command-line-spec+ :sort-names t) (uiop:quit)) 28 | (when version (show-version) (uiop:quit)) 29 | ...) 30 | 31 | (defun main (args) 32 | (handle-command-line 33 | ;; the spec as above, or prepared with prepare-command-line-options-specification 34 | +command-line-spec+ 35 | ;; the function to call with the arguments as parsed 36 | 'my-program-function 37 | ;; the arguments to parse 38 | :command-line args 39 | ;; the program name to use in case of an error message 40 | :name "my-program" 41 | ;; the number of mandatory positional arguments for this command (default: 0) 42 | :positional-arity 2 43 | ;; What to do with the rest of the positional arguments. 44 | ;; T means pass the list of the rest of the command-line-arguments as one lisp argument. 45 | ;; NIL means ignore it. A keyword means pass this rest as a keyword argument. 46 | :rest-arity t)) 47 | 48 | The `define-command` macro may be used to simultaneously define the 49 | following three functions which are useful for defining a function 50 | which may be invoked from the command line. For example, the 51 | following invocation of `define-command` on `FOO` results in: 52 | 53 | (define-command foo (noun verb &spec +command-line-spec+ &aux scratch) 54 | "Usage: foo NOUN VERB [OPTIONS...] 55 | Do VERB to NOUN according to OPTIONS." 56 | #.(format nil "~%Built with ~a version ~a.~%" 57 | (lisp-implementation-type) 58 | (lisp-implementation-version)) 59 | (declare (verbose)) 60 | (when help (show-help-for-foo)) 61 | #|...implementation...|#) 62 | 63 | show-help-for-FOO 64 | : Prints help and option information for FOO to STDOUT and then 65 | exits with `uiop:quit`. 66 | 67 | The docstring passed to `define-command` becomes the help text 68 | printed before options. A second docstring passed as the fourth 69 | argument to `define-command` is printed after the options. 70 | 71 | run-FOO 72 | : Similar to the `main` example above this function is meant to be 73 | used as a `defsystem` `:entry-point`. It runs FOO on the command 74 | line arguments by invoking `handle-command-line`. 75 | 76 | FOO 77 | : The `&body` passed to `define-command` becomes the body of the FOO 78 | function. The positional required command line arguments become 79 | named arguments to FOO and the command line options passed in 80 | behind the `&spec` keyword in the argument list become keyword 81 | arguments to FOO. When supplied `:initial-value` properties of 82 | command lines become defaults of the corresponding keyword 83 | arguments. When supplied `:action` properties of command line 84 | arguments have calls to their actions prepended to the body of the 85 | function. Actions are only called when the keyword argument has a 86 | non-nil value. 87 | 88 | The macro-expanded prototype for FOO in this example would be the 89 | following. 90 | 91 | (DEFUN FOO (NOUN VERB &KEY B CHECK VERBOSE WARN HELP VERSION &AUX SCRATCH)) 92 | 93 | Examples 94 | -------- 95 | 96 | For very simple examples of actual uses, see 97 | my [tthsum](https://gitlab.common-lisp.net/frideau/tthsum/blob/master/main.lisp) clone in Lisp or 98 | my [workout-timer](http://gitlab.common-lisp.net/frideau/workout-timer/blob/master/timer.lisp). 99 | 100 | For a much more elaborate use, see [xcvb](http://gitlab.common-lisp.net/xcvb/xcvb) 101 | — unhappily, XCVB has gone mostly unmaintained since 2012, 102 | so the example might not be usefully runnable. 103 | 104 | 105 | Homepage 106 | -------- 107 | 108 | 109 | 110 | 111 | See also 112 | -------- 113 | 114 | For a fancier take on the same general idea, see Didier Verna's CLON: 115 | 116 | 117 | 118 | CLON has much more features than this library, but is much more complex and slighly less portable. 119 | -------------------------------------------------------------------------------- /parse.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;; ;;; 3 | ;;; Free Software available under an MIT-style license. See LICENSE ;;; 4 | ;;; ;;; 5 | ;;; Copyright (c) 2003-2011 ITA Software, Inc. All rights reserved. ;;; 6 | ;;; Copyright (c) 2011-2012 Google, Inc. All rights reserved. ;;; 7 | ;;; ;;; 8 | ;;; Original author: Francois-Rene Rideau ;;; 9 | ;;; ;;; 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | 12 | #+xcvb (module (:depends-on ("pkgdcl"))) 13 | 14 | (in-package :command-line-arguments) 15 | 16 | (defvar *command-line-options* nil 17 | "command-line options as parsed into a plist") 18 | 19 | (defvar *command-line-option-specification* nil 20 | "the (prepared) specification for how to parse command-line options") 21 | 22 | ;; A raw specification is a list of individual option specifications. 23 | ;; An individual option specification is: 24 | ;; A single option name or a list of option names, and a keyword/value list of option options. 25 | ;; An option name is a single character #\x for short option -x, 26 | ;; or a string "foo" for long option --foo. 27 | ;; option options are: 28 | 29 | ;; :type for specifying a parameter type for the option. 30 | ;; A type may be any of: 31 | ;; NIL - the option takes no parameter. 32 | ;; BOOLEAN - the option takes a boolean parameter. The value can be true, false, yes, no, t, nil, y, n. 33 | ;; If it's a long option, --no-foo is defined, too. 34 | ;; STRING - the option takes a string as parameter 35 | ;; INTEGER - the option takes an integer as parameter, interpreted in decimal. 36 | 37 | ;; :optional for allowing the option to have no parameter 38 | ;; for a list, it allows the final list to be empty. 39 | 40 | ;; :action for specifying an action to do when the option is found 41 | ;; an action may be a symbol to set, a function to call, nil to do nothing, 42 | ;; or a keyword to push on the option plist. 43 | ;; default action is to make a keyword from the first name. 44 | 45 | ;; :list 46 | ;; the value is either T or a plist with keywords :initial-contents and :symbol. 47 | ;; The :type must be integer or string. 48 | ;; :symbol must be a special variable and 49 | ;; :initial-contents must be a list (defaults to the provided initial-value). 50 | ;; While the options are being processed, the special variable is bound to the 51 | ;; initial contents, reversed. 52 | ;; At the end of option processing, the finalizer reverses the list and calls 53 | ;; the action, once. 54 | 55 | ;; :initial-value for specifying an initial value to call the action with 56 | ;; before arguments are parsed. If the action is a keyword (the default) 57 | ;; or symbol, this will provide you with a default value. 58 | ;; :initial-value implies and overrides :optional. 59 | 60 | ;; TODO: add this feature, useful for verbose flags. 61 | ;; :count The value is a plist with keywords :initial-value and :symbol. 62 | ;; A counter is initialized with initial-value (by default 0), 63 | ;; incremented each time the option is invoked, decremented each time. 64 | ;; Alternatively, if the option is given a numeric argument, the counter 65 | ;; is set to the provided argument value. 66 | ;; TODO: add negation for lists with initial-value to allow for empty list. 67 | 68 | ;; :negation Creates string called "no-XXX", or "disable-XXX" if the original name 69 | ;; is "enable-XXX". 70 | 71 | ;; A *prepared* specification is an EQUAL-hash-table that maps option names to 72 | ;; a simple-vector #(action type optional) that specifies what to do when the option 73 | ;; is encountered in the command-line. It also includes three special entries for 74 | ;; keywords :local-symbol :local-values :finalizers that specify the local symbols 75 | ;; to bind when parsing options for this specification, the values to which to bind them, 76 | ;; and a list of finalizers to run after the parsing is done. 77 | 78 | (defun make-option-action (p name 79 | &key (action nil actionp) list optional 80 | (initial-value nil initial-value-p) &allow-other-keys) 81 | "This is called for each option specification when preparing for parsing, and 82 | computes the action function to call (with optional value if provided) 83 | when the option is found on a command-line. 84 | P is the hash-table of actions. 85 | NAME is the first name of this option, a string or a character. 86 | The keywords are option options for this option specification." 87 | (let* ((actual-action (apply #'actual-action-from-spec name 88 | (when actionp (list :action action))))) 89 | (when initial-value-p 90 | (setf optional t) 91 | (push (list 'command-line-action actual-action initial-value) (gethash :initializers p))) 92 | ;; If the :LIST option is not specified, just return the actual-action. 93 | (if (not list) 94 | actual-action 95 | (destructuring-bind (&key (initial-contents initial-value) 96 | (symbol (gensym (string-upcase name)))) 97 | (and (listp list) list) 98 | (push symbol (gethash :local-symbols p)) 99 | (push (reverse initial-contents) (gethash :local-values p)) 100 | (flet ((register-finalizer () 101 | (pushnew (list 'finalize-list name symbol optional actual-action) 102 | (gethash :finalizers p) 103 | :test 'equal))) 104 | (unless optional 105 | (register-finalizer)) 106 | (cons (intern (string-upcase name) :keyword) #'(lambda (value) 107 | (when optional 108 | (register-finalizer)) 109 | (case value 110 | ((nil) (set symbol nil)) 111 | ((t) (error "Option ~A requires a parameter" (option-name name))) 112 | (otherwise (push value (symbol-value symbol))))))))))) 113 | 114 | (defun finalize-list (name symbol optional actual-action) 115 | (let ((value (symbol-value symbol))) 116 | (unless (or optional value) 117 | (error "No option ~A defined" (option-name name))) 118 | (command-line-action actual-action (reverse value)))) 119 | 120 | (defun actual-action-from-spec (name &key (action nil actionp)) 121 | ;; If ACTION is not provided, it's a keyword named NAME. 122 | ;; If ACTION is provided, and this action is a function, nil, a keyword 123 | ;; or other symbol, then it's ACTION. 124 | ;; If ACTION is provided and is a list or the form (FUNCTION FOO) 125 | ;; (as e.g. read by #'FOO) then it's the symbol-function of FOO. 126 | ;; Otherwise, it's an error. 127 | ;; See COMMAND-LINE-ACTION below for how to interpret the results. 128 | ;; When ACTION is a function then return a cons of the keyword of 129 | ;; name and the action. 130 | (cond 131 | ((not actionp) 132 | (intern (string-upcase name) :keyword)) 133 | ((or (functionp action) (symbolp action)) 134 | ;; (keywordp action) and (null action) are implicitly included by symbolp 135 | (cons (intern (string-upcase name) :keyword) action)) 136 | ((and (consp action) (eq 'function (car action)) 137 | (consp (cdr action)) (null (cddr action))) 138 | (cons (intern (string-upcase name) :keyword) 139 | (symbol-function (cadr action)))) 140 | (t 141 | (error "Invalid action spec ~S for option ~S" action name)))) 142 | 143 | (defun command-line-action (action &optional value) 144 | (etypecase action 145 | (null nil) 146 | (keyword (setf *command-line-options* 147 | (list* action value *command-line-options*))) 148 | (symbol (set action value)) 149 | ;; Function actions are saved as (keyword . function). 150 | (cons (setf *command-line-options* 151 | ;; Add the result of calling action to `*command-line-options*'. 152 | (list* (car action) (funcall (cdr action) value) 153 | *command-line-options*))))) 154 | 155 | (defun prepare-command-line-options-specification (specification) 156 | "Given a SPECIFICATION, return a hash-table mapping 157 | option names to a vector of 158 | the action function to call when encountering the option, 159 | the type of option arguments accepted, and 160 | whether the option is optional." 161 | (etypecase specification 162 | (hash-table specification) 163 | (list 164 | (let ((p (make-hash-table :test 'equal))) 165 | (dolist (spec specification) 166 | (destructuring-bind (names &rest option-options 167 | &key type optional list negation (initial-value nil initial-value-p) 168 | action documentation negation-documentation) 169 | spec 170 | (declare (ignorable action initial-value documentation negation-documentation)) 171 | (when initial-value-p 172 | (setf optional t)) 173 | (when list 174 | (unless (member type '(integer string)) 175 | (error "option specification ~S wants list but doesn't specify string or integer" spec))) 176 | (let* ((namelist (if (listp names) names (list names))) 177 | (firstname (car namelist)) 178 | (pos-action (apply 'make-option-action p firstname option-options))) 179 | ;; For each name of this spec, put an entry into the hash table 180 | ;; mapping that name to a vector of the action, the type, and 181 | ;; whether it's optional. 182 | (loop :with spec = (vector pos-action type (and optional (not list))) 183 | :for name :in namelist :do 184 | (setf (gethash name p) spec)) 185 | ;; Deal with negation. 186 | (when (or (eq type 'boolean) list optional) 187 | (let ((neg-action #'(lambda (value) 188 | (command-line-action pos-action (not value)))) 189 | (neg-names (make-negated-names namelist negation))) 190 | (loop :with spec = (vector neg-action nil nil nil) 191 | :for name :in neg-names :do 192 | (setf (gethash name p) spec))))))) 193 | p)))) 194 | 195 | (defun make-negated-names (namelist &optional negation) 196 | (let ((negation-list (if (listp negation) negation (list negation)))) 197 | (loop :for name :in namelist 198 | :when (stringp name) :do 199 | (push (concatenate 'string "no-" name) negation-list) 200 | (when (and (<= 7 (length name)) 201 | (string= "enable-" (subseq name 0 7))) 202 | (push (concatenate 'string "disable-" (subseq name 7 nil)) 203 | negation-list))) 204 | negation-list)) 205 | 206 | (defun command-line-option-specification (option) 207 | (let ((v (gethash option *command-line-option-specification*))) 208 | (if v (values t (svref v 0) (svref v 1) (svref v 2)) (values nil nil nil nil)))) 209 | 210 | (defun short-option-p (arg) 211 | "ARG is a string. Is it like -X, but not -- ?" 212 | (check-type arg simple-string) 213 | (and (<= 2 (length arg)) 214 | (char= #\- (schar arg 0)) 215 | (char/= #\- (schar arg 1)))) 216 | 217 | (defun negated-short-option-p (arg) 218 | "ARG is a string. Is it like +X ?" 219 | (check-type arg simple-string) 220 | (and (<= 2 (length arg)) 221 | (char= #\+ (schar arg 0)))) 222 | 223 | (defun long-option-p (arg) 224 | "ARG is a string. Is it like --XXX ?" 225 | (check-type arg simple-string) 226 | (and (<= 3 (length arg)) 227 | (char= #\- (schar arg 0) (schar arg 1)))) 228 | 229 | (defun option-end-p (arg) 230 | (check-type arg simple-string) 231 | (string= arg "--")) 232 | 233 | (defun option-like-p (arg) 234 | (check-type arg simple-string) 235 | (and (<= 2 (length arg)) 236 | (or (char= #\- (schar arg 0)) 237 | (char= #\+ (schar arg 0))))) 238 | 239 | (defun option-name (option-designator) 240 | (etypecase option-designator 241 | ((eql #\Space) " ") ; the same number of spaces just without the #\- 242 | (character (format nil "-~A" option-designator)) 243 | (string (format nil "--~A" option-designator)))) 244 | 245 | (defun coerce-option-parameter (option string type) 246 | "Given a STRING option argument and a TYPE of argument, 247 | return the argument value as a Lisp object. 248 | OPTION is the name of the option to which the argument is to be passed, 249 | for the sake of error messages." 250 | (flet ((fail () 251 | (error "parameter ~A for option ~A not of type ~A" string (option-name option) type))) 252 | (ecase type 253 | ((nil) 254 | (error "option ~A does not take a parameter" (option-name option))) 255 | ((string) 256 | string) 257 | ((boolean) 258 | (cond 259 | ((member string '("true" "t" "1" "yes" "y") :test #'string-equal) 260 | t) 261 | ((member string '("false" "nil" "0" "no" "n") :test #'string-equal) 262 | nil) 263 | (t 264 | (fail)))) 265 | ((integer) 266 | (multiple-value-bind (value end) (parse-integer string :junk-allowed t) 267 | (unless (and (integerp value) (= end (length string))) (fail)) 268 | value))))) 269 | 270 | (defun get-option-parameter (option type optional) 271 | (cond 272 | ((member type '(boolean t nil)) 273 | t) 274 | ((and optional 275 | (or (null *command-line-arguments*) 276 | (option-like-p (car *command-line-arguments*)))) 277 | t) 278 | (t 279 | (coerce-option-parameter option (pop *command-line-arguments*) type)))) 280 | 281 | (defun process-option (option validp action parameter type optional) 282 | (unless validp (error "Undefined option ~A" (option-name option))) 283 | (typecase parameter 284 | (null 285 | (unless (or (eq type 'boolean) optional) 286 | (error "Option ~A cannot be negated" (option-name option)))) 287 | (string 288 | (setf parameter (coerce-option-parameter option parameter type))) 289 | (t 290 | (setf parameter (get-option-parameter option type optional)))) 291 | (command-line-action action parameter)) 292 | 293 | (defun process-short-option (c &key negated) 294 | (multiple-value-bind (validp action type optional) 295 | (command-line-option-specification c) 296 | (process-option c validp action (not negated) type optional))) 297 | 298 | (defun decompose-long-option-string (string) 299 | (let* ((separator (position #\= string :start 2)) 300 | (name (subseq string 2 separator)) 301 | (parameter (if separator (subseq string (1+ separator)) t))) 302 | (values name parameter))) 303 | 304 | (defun process-long-option (s) 305 | (multiple-value-bind (name parameter) (decompose-long-option-string s) 306 | (multiple-value-bind (validp action type optional) 307 | (command-line-option-specification name) 308 | (process-option name validp action parameter type optional)))) 309 | 310 | (defun do-process-command-line-options () 311 | "Remove all the options and values from *COMMAND-LINE-ARGUMENTS*. 312 | Process each option." 313 | (progv 314 | (gethash :local-symbols *command-line-option-specification*) 315 | (gethash :local-values *command-line-option-specification*) 316 | (loop :for (function . parameters) :in (gethash :initializers *command-line-option-specification*) 317 | :do (apply function parameters)) 318 | (loop :for arg = (pop *command-line-arguments*) :do 319 | (cond 320 | ((or (null arg) (option-end-p arg)) 321 | (return)) 322 | ((short-option-p arg) 323 | (loop :for c :across (subseq arg 1 nil) :do 324 | (process-short-option c))) 325 | ((negated-short-option-p arg) 326 | (loop :for c :across (subseq arg 1 nil) :do 327 | (process-short-option c :negated t))) 328 | ((long-option-p arg) 329 | (process-long-option arg)) 330 | (t 331 | (push arg *command-line-arguments*) ; put the first non-option back before we return. 332 | (return)))) 333 | (loop :for (function . parameters) :in (gethash :finalizers *command-line-option-specification*) 334 | :do (apply function parameters)))) 335 | 336 | (defun process-command-line-options (specification 337 | &optional (command-line *command-line-arguments*)) 338 | "SPECIFICATION is a list as described above. 339 | COMMAND-LINE is the list of tokens to be parsed. 340 | Return two values: 341 | a list of alternating actions and values, and 342 | a list of the arguments remaining after the various specified options." 343 | (let* 344 | ((*command-line-option-specification* 345 | ;; The hash table describing each name. 346 | (prepare-command-line-options-specification specification)) 347 | (*command-line-arguments* 348 | command-line) 349 | (*command-line-options* nil)) 350 | (do-process-command-line-options) 351 | (values *command-line-options* *command-line-arguments*))) 352 | 353 | (defmacro define-command (name args pre-help post-help &rest body) 354 | "Defines show-help-for-NAME, run-NAME, and NAME functions. 355 | 356 | The `define-command' macro may be used to simultaneously define the 357 | following three functions which are useful for defining a function 358 | which may be invoked from the command line. For example, the 359 | following invocation of `define-command' on FOO results in: 360 | 361 | (define-command foo (noun verb &spec +command-line-spec+ &aux scratch) 362 | \"Usage: foo NOUN VERB [OPTIONS...] 363 | Do VERB to NOUN according to OPTIONS.\" 364 | #.(format nil \"~%Built with ~a version ~a.~%\" 365 | (lisp-implementation-type) 366 | (lisp-implementation-version)) 367 | (declare (verbose)) 368 | (when help (show-help-for-foo)) 369 | #|...implementation...|#) 370 | 371 | show-help-for-FOO 372 | : Prints help and option information for FOO to STDOUT. 373 | 374 | The docstring passed to `define-command' becomes the help text 375 | printed before options. A second docstring passed as the fourth 376 | argument to `define-command' is printed after the options. 377 | 378 | run-FOO 379 | : This function is meant to be used as a `defsystem' :ENTRY-POINT. 380 | It runs FOO on the command line arguments by invoking 381 | `handle-command-line'. 382 | 383 | FOO 384 | : The &BODY passed to `define-command' becomes the body of the FOO 385 | function. The positional required command line arguments become 386 | named arguments to FOO and the command line options passed in 387 | behind the &SPEC keyword in the argument list become keyword 388 | arguments to FOO. 389 | 390 | The macro-expanded prototype for FOO in this example would be the 391 | following (where all keyword arguments are option names from 392 | +command-line-spec+). 393 | 394 | (DEFUN FOO (NOUN VERB &KEY B CHECK VERBOSE WARN HELP VERSION &AUX SCRATCH)) 395 | " 396 | (labels ((plist-get (item list &key (test #'eql) &aux last) 397 | (loop :for element :in list :do 398 | (cond 399 | (last (return element)) 400 | ((funcall test item element) (setf last t))))) 401 | (plist-drop-if (predicate list &aux last) 402 | (nreverse (reduce (lambda (acc element) 403 | (cond 404 | (last (setf last nil) acc) 405 | ((funcall predicate element) 406 | (setf last t) acc) 407 | (t (cons element acc)))) 408 | list :initial-value '()))) 409 | (plist-drop (item list &key (test #'eql)) 410 | (plist-drop-if (lambda (el) (funcall test item el)) list)) 411 | (make-keyword (name) 412 | (intern (string name) :keyword)) 413 | (take-while (pred seq) 414 | (if (and (not (null seq)) (funcall pred (car seq))) 415 | (cons (car seq) (take-while pred (cdr seq))) 416 | '())) 417 | 418 | (take-until (pred seq) 419 | (take-while (complement pred) seq)) 420 | (drop-while (pred seq) 421 | (if (and (not (null seq)) (funcall pred (car seq))) 422 | (drop-while pred (cdr seq)) 423 | seq)) 424 | 425 | (drop-until (pred seq) 426 | (drop-while (complement pred) seq)) 427 | (interleave (list sep &optional rest) 428 | (cond 429 | ((cdr list) 430 | (interleave (cdr list) sep (cons sep (cons (car list) rest)))) 431 | (list (reverse (cons (car list) rest))) 432 | (t nil))) 433 | (mapconcat (func list sep) 434 | (apply #'concatenate 'string (interleave (mapcar func list) sep)))) 435 | (let* ((package (package-name *package*)) 436 | (command-line-specification (plist-get (intern "&SPEC" package) args)) 437 | (rest-arg (let ((rest-arg (plist-get (intern "&REST" package) args))) 438 | (when rest-arg (list (intern "&REST" package) rest-arg)))) 439 | (positional-args (take-until 440 | (lambda (el) (equal #\& (aref (symbol-name el) 0))) 441 | (plist-drop (intern "&REST" package) args))) 442 | (aux-args (plist-drop 443 | (intern "&REST" package) 444 | (plist-drop 445 | (intern "&SPEC" package) 446 | (drop-until 447 | (lambda (el) (equal #\& (aref (symbol-name el) 0))) 448 | args)))) 449 | (arity (length positional-args)) 450 | (opts (eval command-line-specification)) 451 | (keys (mapcar 452 | (lambda (el) 453 | (let ((name (intern (string-upcase (caar el)))) 454 | (default (plist-get :initial-value (cdr el)))) 455 | (if default 456 | (list name default) 457 | name))) 458 | opts)) 459 | (command-line-run-p (gensym "COMMAND-LINE-RUN-P")) 460 | (actions (remove nil 461 | (mapcar 462 | (lambda (el) 463 | (let ((action (plist-get :action (cdr el))) 464 | (name (intern (string-upcase (caar el))))) 465 | (when action 466 | `(locally (declare (special ,command-line-run-p)) 467 | (when (and (not ,command-line-run-p) ,name) 468 | (setf ,name (funcall ,action ,name))))))) 469 | opts)))) 470 | (flet ((symcat (&rest syms) 471 | (intern (mapconcat (lambda (el) (string-upcase (string el))) 472 | syms "-")))) 473 | `(locally (declare (special ,command-line-run-p)) 474 | (defvar ,command-line-run-p nil 475 | ,(format nil "True if running ~a from the command line." 476 | (symbol-name name))) 477 | (defun ,(symcat 'show-help-for name) () 478 | ,(format nil "Print help information for `~a' and exit." 479 | (symbol-name name)) 480 | (format t ,(concatenate 'string 481 | ;; Prepend usage information for command-line help. 482 | (format nil "Usage: ~a [OPTION]... ~{~a~^ ~}~a~%~%" 483 | (string-downcase (symbol-name name)) 484 | (mapcar #'symbol-name positional-args) 485 | ;; Add &REST argument to command line usage. 486 | (let ((rest-args (member '&rest args))) 487 | (if (and rest-args 488 | command-line-specification) 489 | (concatenate 490 | 'string " [" 491 | (symbol-name (second rest-args)) 492 | "]...") 493 | ""))) 494 | pre-help)) 495 | (format t "~&~%OPTIONS:~%") 496 | (show-option-help ,command-line-specification :sort-names t) 497 | (format t ,post-help)) 498 | 499 | (defun ,(symcat 'run name) () 500 | ,(format nil "Run `~a' on `*command-line-arguments*'." 501 | (symbol-name name)) 502 | ;; Unless the main function takes rest arguments check for 503 | ;; exact number of positional arguments. 504 | (setf *lisp-interaction* nil) 505 | (let ((,command-line-run-p t)) 506 | (declare (special ,command-line-run-p)) 507 | (in-package ,(make-keyword package)) 508 | (handler-case 509 | (handle-command-line 510 | ,command-line-specification ',name 511 | :name ,(symbol-name name) ; Alternately (argv0). 512 | :positional-arity ,arity ; Positional arguments. 513 | :rest-arity 514 | ,(if (member '&rest args) 515 | (if command-line-specification 516 | ;; NOTE: If both rest and 517 | ;; keyword arguments convert 518 | ;; the rest of the command 519 | ;; line arguments into a 520 | ;; keyword argument. 521 | (make-keyword (second rest-arg)) 522 | ;; Otherwise keep/pass as a 523 | ;; normal &rest argument. 524 | t) 525 | nil)) 526 | (command-line-arity (c) 527 | ;; Don't print the arity requirement if the first 528 | ;; argument looks like it's asking for help. 529 | (unless (let ((it (car *command-line-arguments*))) 530 | (and it (stringp it) 531 | (or (string= it "-h") 532 | (string= it "-?") 533 | (string= it "--help")))) 534 | (format t "~A~%" c)) 535 | (,(symcat 'show-help-for name)) 536 | (return-from ,(symcat 'run name)))) 537 | 0)) 538 | 539 | (defun ,name 540 | ,(append positional-args 541 | (unless command-line-specification rest-arg) 542 | (when keys 543 | (cons '&key 544 | ;; NOTE: See above note. Convert &rest 545 | ;; args to a keyword argument when other 546 | ;; keyword arguments are given via the 547 | ;; COMMAND-LINE-SPECIFICATION. 548 | (if (and rest-arg command-line-specification) 549 | (cons (second rest-arg) keys) 550 | keys))) 551 | aux-args) 552 | ,(with-output-to-string (str) 553 | (format str "~a~&~%Keyword arguments:~%" pre-help) 554 | (show-option-help opts :sort-names t :stream str :docstring t)) 555 | ;; Don't accidentally place the actions before a DECLARE 556 | ;; form at the top of the function body. 557 | ,@(if (and actions 558 | (listp (car body)) 559 | (eql 'declare (caar body))) 560 | (append (list (car body)) 561 | actions 562 | (cdr body)) 563 | body))))))) 564 | --------------------------------------------------------------------------------