diff --git a/.gitignore b/.gitignore index d0f1392..323c1b5 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ *.fas *.fasl *~ +*.o \#* diff --git a/.travis.yml b/.travis.yml index a95f942..dcd7df8 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,14 @@ language: lisp sudo: required +addons: + apt: + sources: + - ubuntu-toolchain-r-test + packages: + - libstdc++-7-dev + - lib32stdc++-7-dev + env: matrix: - LISP=abcl @@ -10,21 +18,26 @@ env: - LISP=ccl32 - LISP=clisp - LISP=clisp32 + - LISP=ecl + - LISP=allegro + +matrix: + allow_failures: + - env: LISP=ccl32 # issue filed at https://github.com/Clozure/ccl/issues/304 install: - - if [ -x ./install.sh ] && head -2 ./install.sh | grep '^# cl-travis' > /dev/null; + - # installing cl-travis + if [ -x ./install.sh ] && head -2 ./install.sh | grep '^# cl-travis' > /dev/null; then ./install.sh; else - curl https://raw.githubusercontent.com/luismbo/cl-travis/master/install.sh | sh; + curl https://raw.githubusercontent.com/sionescu/cl-travis/master/install.sh | sh; fi -before_script: - - echo "(defsystem :dummy-cl-travis-system)" > ~/lisp/dummy-cl-travis-system.asd - script: - - cl -e '(asdf:load-system :unix-opts-tests) - (unix-opts:run-tests)' + - cl -e '(ql:quickload :unix-opts) + (ql:quickload :unix-opts/tests) + (unix-opts/tests:run)' [ $? -eq 1 ] notifications: diff --git a/README.md b/README.md index 9f7f7a3..8f01967 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ # Unix-style command line options parser [![License MIT](https://img.shields.io/badge/license-MIT-green.svg)](http://opensource.org/licenses/MIT) -[![Build Status](https://travis-ci.org/mrkkrp/unix-opts.svg?branch=master)](https://travis-ci.org/mrkkrp/unix-opts) +[![Build Status](https://travis-ci.org/digikar99/unix-opts.svg?branch=master)](https://travis-ci.com/digikar99/unix-opts.svg?branch=master) [![Quicklisp](http://quickdocs.org/badge/unix-opts.svg)](http://quickdocs.org/unix-opts/) This is a minimalistic parser of command line options. The main advantage of diff --git a/tests.lisp b/tests.lisp index 5809858..cd8c015 100644 --- a/tests.lisp +++ b/tests.lisp @@ -23,40 +23,47 @@ ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -(in-package #:unix-opts) +(defpackage :unix-opts/tests + (:shadowing-import-from :cl :describe) + (:use :cl :unix-opts) + (:export :run)) -(define-opts +(in-package :unix-opts/tests) + +(opts:define-opts (:name :grab-int - :description "grab integer INT" - :short #\i - :long "grab-int" - :required t - :arg-parser #'parse-integer - :meta-var "INT") + :description "grab integer INT" + :short #\i + :long "grab-int" + :required t + :arg-parser #'parse-integer + :meta-var "INT") (:name :grab-str - :description "grab string STR" - :short #\s - :long "grab-str" - :arg-parser #'identity - :meta-var "STR") + :description "grab string STR" + :short #\s + :long "grab-str" + :arg-parser #'identity + :meta-var "STR") + (:name :grab-string + :description "option to cause ambiguity with grab-str as well as help test the print function of opts:describe due to this long description" + :short #\s + :long "grab-string" + :arg-parser #'identity + :default 42) (:name :flag-a - :description "flag with short form only" - :short #\a) + :description "flag with short form only" + :short #\a) (:name :flag-b - :description "flag with long form only" - :long "flag-b")) + :description "flag with long form only" + :long "flag-b")) ;;; Here is some variables that we will use and functions to reset them. -(defparameter *unknown-options* nil - "We collect all unknown options here.") - +(defparameter *unknown-options* nil "We collect all unknown options here.") +(defparameter *ambiguous-options* nil "We collect all ambiguous options here.") (defparameter *missing-arg-options* nil "Options that need an argument, but don't get one.") - -(defparameter *malformed-arguments* nil - "Here we collect malformed arguments.") - +(defparameter *malformed-arguments* nil "Here we collect malformed arguments.") (defparameter *missing-required-options* "Here we collect missing required options.") @@ -77,7 +84,8 @@ aspects of the tests." ;;; The tests themselves. -(defun parse-opts (opts &key unknown-option missing-arg arg-parser-failed missing-required) +(defun parse-opts (opts &key unknown-option missing-arg arg-parser-failed + missing-required ambiguous-option) "Parse OPTS, return results and collect some data in special variables. Keyword arguments allow to set arguments for `invoke-restart' function. It's recommended to supply them all if you don't want to end in the debugger." @@ -85,117 +93,195 @@ recommended to supply them all if you don't want to end in the debugger." (multiple-value-prog1 (handler-bind ((unknown-option - (lambda (c) - (push (option c) *unknown-options*) - (when unknown-option - (apply #'invoke-restart unknown-option)))) + (lambda (c) + (push (option c) *unknown-options*) + (when unknown-option + (apply #'invoke-restart unknown-option)))) + (ambiguous-option + (lambda (c) + (push (option c) *ambiguous-options*) + (when ambiguous-option + (apply #'invoke-restart ambiguous-option)))) (missing-arg - (lambda (c) - (push (option c) *missing-arg-options*) - (when missing-arg - (apply #'invoke-restart missing-arg)))) + (lambda (c) + (push (option c) *missing-arg-options*) + (when missing-arg + (apply #'invoke-restart missing-arg)))) (missing-required-option - (lambda (c) - (push (mapcar #'name (missing-options c)) *missing-required-options*) - (when missing-required - (apply #'invoke-restart missing-required)))) + (lambda (c) + ;; TODO: Should we export unix-opts::name? + (push (mapcar #'unix-opts::name (missing-options c)) *missing-required-options*) + (when missing-required + (apply #'invoke-restart missing-required)))) (arg-parser-failed - (lambda (c) - (push (raw-arg c) *malformed-arguments*) - (when arg-parser-failed - (apply #'invoke-restart arg-parser-failed))))) + (lambda (c) + (push (raw-arg c) *malformed-arguments*) + (when arg-parser-failed + (apply #'invoke-restart arg-parser-failed))))) (get-opts opts)) (finish-collecting))) -(defun run-tests () - "Run Unix-opts tests. Signal failure if any test fails and return NIL -otherwise." - (assert (typep (argv) 'list)) +(defun argv-test () + (assert (typep (opts:argv) 'list))) + +(defun unexpected-options-test () + (assert (typep (handler-case (opts:get-opts '("--grab-int" "10" "--rere")) + (condition (c) c)) + 'unknown-option)) + (assert (typep (handler-case (opts:get-opts '()) + (condition (c) c)) + 'missing-required-option)) + (assert (typep (handler-case (opts:get-opts '("--grab-int" "hello")) + (condition (c) c)) + 'arg-parser-failed)) + (assert (typep (handler-case (opts:get-opts '("--grab-int")) + (condition (c) c)) + 'missing-arg)) + ;; TODO: Should we error in the following case? + (assert (typep (handler-case (opts:get-opts '("--grab-int" "10" "-a" "11")) + (condition (c) c)) + 'list))) +(defun miscelleneous-1 () (multiple-value-bind (options free-args) (parse-opts '("--grab-int" "10" "--rere" "11" "-s" "-a" "foo.txt") :unknown-option '(skip-option) :missing-arg '(skip-option) :arg-parser-failed '(skip-option)) - (assert (equalp options '(:grab-int 10 :flag-a t))) + (assert (equalp options '(:grab-int 10 :flag-a t + :grab-string 42))) (assert (equalp free-args '("11" "foo.txt"))) (assert (equalp *unknown-options* '("--rere"))) (assert (equalp *missing-arg-options* '("-s"))) - (assert (equalp *malformed-arguments* nil))) + (assert (equalp *malformed-arguments* nil)))) + +(defun miscelleneous-2 () (multiple-value-bind (options free-args) (parse-opts '("-asri=13" "--flag-b" "--flag-b" "foo.txt" "bar.txt") :unknown-option '(skip-option) :missing-arg '(skip-option) :arg-parser-failed '(skip-option)) - (assert (equalp options '(:flag-a t :grab-int 13 :flag-b t :flag-b t))) + (assert (equalp options '(:flag-a t :grab-int 13 :flag-b t :flag-b t + :grab-string 42))) (assert (equalp free-args '("foo.txt" "bar.txt"))) (assert (equalp *unknown-options* '("-r"))) (assert (equalp *missing-arg-options* '("-s"))) - (assert (equalp *malformed-arguments* nil))) + (assert (equalp *malformed-arguments* nil)))) + +(defun miscelleneous-3 () (multiple-value-bind (options free-args) (parse-opts '("--grab-str=fooba" "-i" "what" "-i" "100" "--roro" "-") :unknown-option '(skip-option) :missing-arg '(skip-option) :arg-parser-failed '(skip-option)) - (assert (equalp options '(:grab-str "fooba" :grab-int 100))) + (assert (equalp options '(:grab-str "fooba" :grab-int 100 + :grab-string 42))) (assert (equalp free-args '("-"))) (assert (equalp *unknown-options* '("--roro"))) (assert (equalp *missing-arg-options* nil)) - (assert (equalp *malformed-arguments* '("what")))) + (assert (equalp *malformed-arguments* '("what"))))) + +(defun miscelleneous-4 () (multiple-value-bind (options free-args) (parse-opts '("--foobar" "cat" "-sl") ; very tricky (see restarts) :unknown-option '(use-value "--grab-int") :missing-arg '(use-value "my-string") :arg-parser-failed '(reparse-arg "15")) (assert (equalp options '(:grab-int 15 :grab-str "my-string" - :grab-int "my-string"))) + :grab-int "my-string" ; TODO: should this be the behaviour + :grab-string 42))) (assert (equalp free-args nil)) (assert (equalp *unknown-options* '("--foobar" "-l"))) (assert (equalp *missing-arg-options* '("-s" "--grab-int"))) - (assert (equalp *malformed-arguments* '("cat")))) + (assert (equalp *malformed-arguments* '("cat"))))) + +(defun miscelleneous-5 () (multiple-value-bind (options free-args) - (parse-opts '("--grab-i" "10" "--grab" "14" "--grab-s") + (parse-opts '("--grab-int" "10" "--grab" "14" "--grab-s") :unknown-option '(skip-option) :missing-arg '(skip-option) - :arg-parser-failed '(skip-option)) - (assert (equalp options '(:grab-int 10))) + :arg-parser-failed '(skip-option) + :ambiguous-option '(skip-option)) + (assert (equalp options '(:grab-int 10 + :grab-string 42))) (assert (equalp free-args '("14"))) - (assert (equalp *unknown-options* '("--grab"))) - (assert (equalp *missing-arg-options* '("--grab-s"))) - (assert (equalp *malformed-arguments* nil))) + (assert (null (set-difference *ambiguous-options* '("--grab" "--grab-s") + :test #'equal))) + (assert (equalp *malformed-arguments* nil)))) + +(defun miscelleneous-6 () (multiple-value-bind (options free-args) (parse-opts '("--grab-int" "15" "--" "--grab-int" "16") :unknown-option '(skip-option) :missing-arg '(skip-option) :arg-parser-failed '(skip-option)) - (assert (equalp options '(:grab-int 15))) + (assert (equalp options '(:grab-int 15 + :grab-string 42))) (assert (equalp free-args '("--grab-int" "16"))) (assert (equalp *unknown-options* nil)) (assert (equalp *missing-arg-options* nil)) - (assert (equalp *malformed-arguments* nil))) + (assert (equalp *malformed-arguments* nil)))) + +(defun miscelleneous-7 () (multiple-value-bind (options free-args) (parse-opts '("-s" "5") :unknown-option '(skip-option) :missing-arg '(skip-option) :missing-required '(skip-option) :arg-parser-failed '(skip-option)) - (assert (equalp options '(:grab-str "5"))) + (assert (equalp options '(:grab-str "5" + :grab-string 42))) (assert (equalp free-args '())) (assert (equalp *missing-required-options* '((:grab-int)))) (assert (equalp *unknown-options* nil)) (assert (equalp *missing-arg-options* nil)) - (assert (equalp *malformed-arguments* nil))) + (assert (equalp *malformed-arguments* nil)))) + +(defun miscelleneous-8 () (multiple-value-bind (options free-args) (parse-opts '("-s" "5") :unknown-option '(skip-option) :missing-arg '(skip-option) :missing-required '(use-value (15)) :arg-parser-failed '(skip-option)) - (assert (equalp options '(:grab-str "5" :grab-int 15))) + (assert (equalp options '(:grab-str "5" :grab-int 15 + :grab-string 42))) (assert (equalp free-args '())) (assert (equalp *missing-required-options* '((:grab-int)))) (assert (equalp *unknown-options* nil)) (assert (equalp *missing-arg-options* nil)) (assert (equalp *malformed-arguments* nil)))) -(export 'run-tests) +(defun expand-opts-test () + (assert (equalp + (macroexpand-1 + '(opts:expand-opts + (:help "Show this help text.") + (:port "Port number on which to run the server." #'parse-integer t) + (:swank-port "Port number at which to start swank [default: 8080]" #'parse-integer) + (:debug "Run in debug mode if specified" #'identity))) + '(UNIX-OPTS:DEFINE-OPTS + (:NAME :HELP :DESCRIPTION "Show this help text." :SHORT #\h :REQUIRED NIL + :LONG "help" :ARG-PARSER NIL) + (:NAME :PORT :DESCRIPTION "Port number on which to run the server." :SHORT + #\p :REQUIRED T :LONG "port" :ARG-PARSER #'PARSE-INTEGER) + (:NAME :SWANK-PORT :DESCRIPTION + "Port number at which to start swank [default: 8080]" :SHORT #\s :REQUIRED + NIL :LONG "swank-port" :ARG-PARSER #'PARSE-INTEGER) + (:NAME :DEBUG :DESCRIPTION "Run in debug mode if specified" :SHORT #\d + :REQUIRED NIL :LONG "debug" :ARG-PARSER #'IDENTITY))))) + +(defun run () + (dolist (fn '(argv-test unexpected-options-test + miscelleneous-1 + miscelleneous-2 + miscelleneous-3 + miscelleneous-4 + miscelleneous-5 + miscelleneous-6 + miscelleneous-7 + miscelleneous-8 + expand-opts-test)) + (funcall fn) + (format t "~D ran successfully~%" fn)) + (format t "All tests ran successfully!")) diff --git a/unix-opts-tests.asd b/unix-opts-tests.asd deleted file mode 100644 index d96d67e..0000000 --- a/unix-opts-tests.asd +++ /dev/null @@ -1,32 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- -;;; -;;; ASDF system definition for unix-opts-tests -;;; -;;; Copyright © 2015–2018 Mark Karpov -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a -;;; copy of this software and associated documentation files (the -;;; "Software"), to deal in the Software without restriction, including -;;; without limitation the rights to use, copy, modify, merge, publish, -;;; distribute, sublicense, and/or sell copies of the Software, and to -;;; permit persons to whom the Software is furnished to do so, subject to -;;; the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included -;;; in all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -;;; OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -(asdf:defsystem :unix-opts-tests - :version "0.1.7" - :description "tests for unix-opts-tests" - :author "Mark Karpov" - :license "MIT" - :components ((:file "tests")) - :depends-on (:unix-opts)) diff --git a/unix-opts.asd b/unix-opts.asd index 83910ac..95ce4eb 100644 --- a/unix-opts.asd +++ b/unix-opts.asd @@ -24,9 +24,18 @@ ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -(asdf:defsystem :unix-opts +(asdf:defsystem "unix-opts" :version "0.1.7" :description "minimalistic parser of command line arguments" :author "Mark Karpov" :license "MIT" + ;; clisp doesn't seem to support in-order-to and uiop and such, nor fiveam :components ((:file "unix-opts"))) + +(asdf:defsystem "unix-opts/tests" + :version "0.1.7" + :description "tests for unix-opts" + :author "Mark Karpov" + :license "MIT" + :components ((:file "tests")) + :depends-on ("unix-opts")) diff --git a/unix-opts.lisp b/unix-opts.lisp index d557698..6f84f25 100644 --- a/unix-opts.lisp +++ b/unix-opts.lisp @@ -26,7 +26,9 @@ (defpackage :unix-opts (:nicknames :opts) (:use #:common-lisp) - (:export #:unknown-option + (:export #:troublesome-option + #:unknown-option + #:ambiguous-option #:missing-arg #:arg-parser-failed #:missing-required-option @@ -38,6 +40,7 @@ #:exit #:raw-arg #:define-opts + #:expand-opts #:argv #:get-opts #:describe) @@ -77,7 +80,13 @@ parsed with this function") :initarg :meta-var :accessor meta-var :documentation "if this option requires an argument, this is how it will -be printed in option description")) +be printed in option description") + (default + :initarg :default + :initform nil + :accessor default + :documentation "if this option requires an argument, this is the value that will be +used if the option is not supplied")) (:documentation "representation of an option")) (define-condition troublesome-option (simple-error) @@ -94,6 +103,14 @@ particular option.")) (:documentation "This condition is thrown when parser encounters unknown (not previously defined with `define-opts') option.")) +(define-condition ambiguous-option (troublesome-option) + ((matches :initarg :matches :reader matches)) + (:report (lambda (c s) (format s "ambiguous option: ~s~%Matches to ~a" + (option c) (mapcar #'long (matches c))))) + (:documentation "This condition is thrown when parser encounters +an option that could possibly parse to more than one option. Such a situation +arises, for example, in `ls --al`.")) + (define-condition missing-arg (troublesome-option) () (:report (lambda (c s) (format s "missing arg for option: ~s" (option c)))) @@ -139,7 +156,8 @@ an argument, it's given but cannot be parsed by argument parser.")) (long (getf args :long)) (arg-parser (getf args :arg-parser)) (required (getf args :required)) - (meta-var (getf args :meta-var "ARG"))) + (meta-var (getf args :meta-var "ARG")) + (default (getf args :default nil))) (unless (or short long) (error "at least one form of the option must be provided")) (check-type name keyword) @@ -156,7 +174,8 @@ an argument, it's given but cannot be parsed by argument parser.")) :long long :required required :arg-parser arg-parser - :meta-var meta-var) + :meta-var meta-var + :default default) *options*))) (defmacro define-opts (&body descriptions) @@ -187,11 +206,45 @@ printed in option description." (setf *options* (nreverse *options*)) (values))) +(defmacro expand-opts (&body descriptions) + "Each description should be of the format + (name-as-keyword description &optional parser required short). +So that something as short as the following gets the work done. + (expand-opts + (:help \"Show this help text.\") + (:port \"Port number on which to run the server.\" #'parse-integer t) + (:swank-port \"Port number at which to start swank [default: 8080]\" #'parse-integer) + (:debug \"Run in debug mode if specified\" #'identity))" + `(opts:define-opts + ,@(let* ((used-short-names (make-hash-table)) + (get-unique-short-name + (lambda (name) + (loop for ch across name + do (when (and (not (gethash ch used-short-names)) + (alpha-char-p ch)) + (setf (gethash ch used-short-names) t) + (return ch)) + finally + (error "Could not find a unique short name for ~D" name))))) + (loop for description in descriptions + collect + (destructuring-bind (name description &optional + parser required short) + description + (let ((name-string (string-downcase (symbol-name name)))) + `(:name ,name + :description ,description + :short ,(or short (funcall get-unique-short-name + name-string)) + :required ,required + :long ,name-string + :arg-parser ,parser))))))) + (defun argv () "Return a list of program's arguments, including command used to execute the program as first elements of the list. Portable across implementations." #+abcl ext:*command-line-argument-list* - #+allegro sys:command-line-arguments + #+allegro (sys:command-line-arguments) #+:ccl ccl:*command-line-argument-list* #+clisp (cons *load-truename* ext:*args*) #+clozure ccl:*command-line-argument-list* @@ -254,12 +307,16 @@ the program as first elements of the list. Portable across implementations." (let ((x (string x))) (when (>= (length x) (length opt)) (string= x opt :end1 (length opt)))))) - (let ((matches (remove-if-not #'prefix-p *options* :key key))) - (if (cadr matches) - nil - (car matches)))))) - -(defun get-opts (&optional options) + ;; Yes we use prefix, because `ls --al`, `ls --all`, `ls --alm`. + (let* ((matches (remove-if-not #'prefix-p *options* :key key)) + (exact-match (find-if #'(lambda (x) (string= x opt)) + matches :key key))) + (cond + (exact-match exact-match) + ((cadr matches) matches) + (t (car matches))))))) + +(defun get-opts (&optional (options nil options-supplied-p)) "Parse command line options. If OPTIONS is given, it should be a list to parse. If it's not given, the function will use `argv' function to get list of command line arguments. @@ -301,13 +358,15 @@ be used), `skip-option' (ignore all these options, effectively binding them to `nil')" (do ((tokens (mapcan #'split-short-opts (mapcan #'split-on-= - (or options (cdr (argv))))) + (if options-supplied-p + options + (cdr (argv))))) (cdr tokens)) (required (loop :with table = (make-hash-table) - :for option :in *options* - :when (required option) - :do (setf (gethash (name option) table) option) - :finally (return table))) + :for option :in *options* + :when (required option) + :do (setf (gethash (name option) table) option) + :finally (return table))) poption-name poption-raw poption-parser @@ -318,16 +377,23 @@ to `nil')" (progn (when (/= (hash-table-count required) 0) (let ((missing (loop :for val :being :the :hash-values :of required - :collect val))) + :collect val))) (restart-case (error 'missing-required-option :missing-options missing) (skip-option ()) (use-value (values) (loop :for option :in missing - :for value :in values - :do (push (name option) options) - :do (push value options)))))) + :for value :in values + :do (push (name option) options) + :do (push value options)))))) + ;; handle default options + (loop :for option :in *options* + :for name = (name option) + :when (and (default option) + (null (getf options name))) + :do (push name options) + (push (default option) options)) (values (nreverse options) (nreverse free-args)))) (labels ((push-option (name value) @@ -352,38 +418,38 @@ to `nil')" (process-arg str)))) (process-option (opt) (let ((option (find-option opt))) - (if option - (let ((parser (arg-parser option))) - (remhash (name option) required) - (if parser - (setf poption-name (name option) - poption-raw opt - poption-parser parser) - (push-option (name option) t))) - (restart-case - (error 'unknown-option - :option opt) - (use-value (value) - (process-option value)) - (skip-option ())))))) + (cond ((and (listp option) (cadr option)) ; (> length 1) + (restart-case (error 'ambiguous-option :option opt + :matches option) + (use-value (value) (process-option value)) + (skip-option ()))) + (option + (let ((parser (arg-parser option))) + (remhash (name option) required) + (if parser + (setf poption-name (name option) + poption-raw opt + poption-parser parser) + (push-option (name option) t)))) + (t + (restart-case + (error 'unknown-option :option opt) + (use-value (value) (process-option value)) + (skip-option ()))))))) (let ((item (car tokens))) (cond ((and poption-name (argp item)) (process-arg item)) (poption-name (restart-case - (error 'missing-arg - :option poption-raw) + (error 'missing-arg :option poption-raw) (use-value (value) (push-option poption-name value) - (when item - (process-option item))) + (when item (process-option item))) (skip-option () (setf poption-name nil) - (when item - (process-option item))))) + (when item (process-option item))))) ((string= item "--") - (dolist (tok (cdr tokens)) - (push tok free-args)) + (dolist (tok (cdr tokens)) (push tok free-args)) (setf tokens nil)) ((optionp item) (process-option item)) @@ -394,37 +460,55 @@ to `nil')" prefixed with PADDING spaces. If NEWLINE is non-NIL, newline character will be prepended to the text making it start on the next line with padding applied to every single line." - (let ((pad (make-string padding :initial-element #\Space))) + (let ((pad (make-string padding :initial-element #\Space)) + (pad-next-lines (make-string (max 0 (1- padding)) :initial-element #\Space))) (with-output-to-string (s) (when newline - (format s "~&~a" pad)) + (format s "~%~a" pad)) (map nil (lambda (x) (write-char x s) (when (char= x #\Newline) - (write pad :stream s :escape nil))) + (write pad-next-lines :stream s :escape nil))) str)))) (defun print-opts (&optional (stream *standard-output*)) "Print info about defined options to STREAM. Every option get its own line with description." - (dolist (opt *options*) - (with-slots (short long description required arg-parser meta-var) opt - (let ((opts-and-meta - (concatenate - 'string - (if short (format nil "-~c" short) "") - (if (and short long) ", " "") - (if long (format nil "--~a" long) "") - (if arg-parser (format nil " ~a" meta-var) "") - (if required (format nil " (Required)") "")))) - (format stream " ~25a~a~%" - opts-and-meta - (add-text-padding - description - :padding 27 - :newline (>= (length opts-and-meta) 25)))))) - (terpri stream)) + (flet ((pad-right (string max-size) + (concatenate 'string + string + (make-string (- max-size + (length string)) + :initial-element #\Space)))) + (let ((max-opts-length -1) + (all-opts-meta ()) + (all-opts-descriptions ())) + (dolist (opt *options*) + (with-slots (short long description required arg-parser meta-var) opt + (let ((opts-and-meta + (concatenate + 'string + (if short (format nil "-~c" short) "") + (if (and short long) ", " "") + (if long (format nil "--~a" long) "") + (if arg-parser (format nil " ~a" meta-var) "") + (if required (format nil " (Required)") "")))) + (push opts-and-meta all-opts-meta) + (push description all-opts-descriptions) + (when (> (length opts-and-meta) + max-opts-length) + (setf max-opts-length + (length opts-and-meta)))))) + (setf max-opts-length (+ 1 max-opts-length)) + (loop + for opt-meta in all-opts-meta + for opt-description in all-opts-descriptions do + (format stream " ~a~a~%" + (pad-right opt-meta max-opts-length) + (add-text-padding opt-description + :padding (+ 2 max-opts-length)))) + (terpri stream)))) (defun print-opts* (margin) "Return a string containing info about defined options. All options are @@ -445,13 +529,13 @@ it gets too long. MARGIN specifies margin." (if long (format nil "--~a" long) "") (if arg-parser (format nil " ~a" meta-var) "") (if required (format nil " (Required)") ""))))) - (incf i (length str)) - (when (> (- i last-newline) fill-col) - (terpri s) - (dotimes (x margin) - (princ #\space s)) - (setf last-newline i)) - (princ str s))))))) + (incf i (length str)) + (when (> (- i last-newline) fill-col) + (terpri s) + (dotimes (x margin) + (princ #\space s)) + (setf last-newline i)) + (princ str s))))))) (defun describe (&key prefix suffix usage-of args (stream *standard-output*)) "Return string describing options of the program that were defined with