From: Frank Duncan Date: Sun, 20 Dec 2020 05:18:04 +0000 (-0600) Subject: Initial version X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?a=commitdiff_plain;h=57382c64deeded63abbc5b1417e69dfd3db07fbf;p=opera Initial version --- 57382c64deeded63abbc5b1417e69dfd3db07fbf diff --git a/opera.asd b/opera.asd new file mode 100644 index 0000000..6f4d960 --- /dev/null +++ b/opera.asd @@ -0,0 +1,8 @@ +(asdf:defsystem opera + :name "Simple getopts tool for common lisp" + :version "0.1" + :maintainer "Frank Duncan (frank@consxy.com)" + :author "Frank Duncan (frank@consxy.com)" + :serial t + :pathname "src/main" + :components ((:file "opera"))) diff --git a/src/main/opera.lisp b/src/main/opera.lisp new file mode 100644 index 0000000..0d70f9f --- /dev/null +++ b/src/main/opera.lisp @@ -0,0 +1,193 @@ +(defpackage #:opera + (:use :common-lisp) + (:export #:process-arguments #:usage + #:invalid-option-definition #:invalid-option-reason #:invalid-option-option + #:option-present #:option-argument #:option-arguments)) + +; - :name - name returned +; - :short - single character, yes! +; - :long - long form, double yes +; - :takes-argument - t/nil, defaulting to nil, if t, consumes the next thign and sets it as the argument +; - :description - desc of option, the formatting of which has to be done by the software writer +; - :variable-name - for auto printing help, if ommitted, not used +; - :required - for auto printing help, if included, the brackets are omitted +; - probably doesn't make much sense for non positional options (or else, why are they options?) +; - :positional - for auto printing help, for arguments that aren't related to options + + +(in-package #:opera) + +(define-condition invalid-option-definition nil + ((reason :initarg :reason :reader invalid-option-reason) + (option :initarg :option :reader invalid-option-option)) + (:report + (lambda (c str) + (format str "Invalid option definition (~A) for option (~A)" (invalid-option-reason c) (invalid-option-option c))))) + +; validate that the things we need +(defun validate-option (option &optional for-usage) + (labels + ((invalid (reason) (error (make-instance 'invalid-option-definition :reason reason :option option))) + (option-val (key) + (handler-case + (getf option key) + (error (e) (error (make-instance 'invalid-option-definition :reason e :option e)))))) + (cond + ((not (list option)) (invalid "Option is not a list")) + ((and (not (option-val :name)) (not (option-val :positional))) (invalid ":name required")) + ((and (not (option-val :positional)) (not (option-val :short)) (not (option-val :long))) (invalid ":long or :short required")) + ((and for-usage (not (option-val :description))) (invalid ":description required for usage")) + ((and for-usage (option-val :takes-argument) (not (option-val :variable-name))) + (invalid ":variable-name required for usage when :takes-argument present"))))) + +(defun starts-with-hyphen (arg) + (and (< 0 (length arg)) (eql #\- (aref arg 0)))) + +(defun option-matching-arg (options arg) + (when arg + (find-if + (lambda (option) + (or + (and (getf option :short) (string= arg (format nil "-~A" (getf option :short)))) + (and (getf option :long) (string= arg (format nil "--~A" (getf option :long)))))) + options))) + +(defun process (options args) + (let + ((option (option-matching-arg options (car args)))) + (cond + ((and (not option) (starts-with-hyphen (car args))) (values nil args :unknown-option)) + ((not option) (values nil args)) + ((and (getf option :takes-argument) (= 1 (length args))) + (values nil args :required-argument-missing)) + ((getf option :takes-argument) + (multiple-value-bind (result remaining-args error) (process options (cddr args)) + (values + (cons (list (getf option :name) (cadr args)) result) + remaining-args + error))) + (t + (multiple-value-bind (result remaining-args error) (process options (cdr args)) + (values + (cons (list (getf option :name)) result) + remaining-args + error)))))) + +(defun process-arguments (options args) + (mapcar #'validate-option options) + (process options args)) + +(defun create-usage-line (command options line-width) + (let* + ((command-width (+ (length "usage: ") (length command))) + (width-available (- line-width command-width))) + (when (> 0 width-available) + (error "Command ~A too long for line-width ~A" command line-width)) + (labels + ((process-options (remaining-options &optional current-strings) + (if (not remaining-options) + (format nil + (format nil "~~A~~{~~,,~A~~A~~}" command-width) + (car (reverse current-strings)) + (cdr (reverse current-strings))) + (let* + ((option (car remaining-options)) + (option-string + (format nil "~A~A~A~A~A~A~A~A" + (if (getf option :required) "" "[") + (if (getf option :short) (format nil "-~A" (getf option :short)) "") + (if (and (getf option :short) (getf option :takes-argument)) + (format nil " ~A" (getf option :variable-name)) + "") + (if (and (getf option :short) (getf option :long)) " | " "") + (if (getf option :long) (format nil "--~A" (getf option :long)) "") + (if (and (getf option :long) (getf option :takes-argument)) + (format nil " ~A" (getf option :variable-name)) + "") + (or (getf option :positional) "") + (if (getf option :required) "" "]")))) + (when (> (length option-string) width-available) + (error "Option ~A too long for line-width ~A" option-string line-width)) + (cond + ((not current-strings) (process-options (cdr remaining-options) (list option-string))) + ((< width-available (+ 1 (length option-string) (length (car current-strings)))) + (process-options (cdr remaining-options) (cons option-string current-strings))) + (t + (process-options + (cdr remaining-options) + (cons + (format nil "~A ~A" (car current-strings) option-string) + (cdr current-strings))))))))) + (format nil "usage: ~A ~A" command (process-options options))))) + +(defun option-string-for-long-description (option) + (format nil "~A~A~A~A~A~A" + (if (getf option :short) (format nil "-~A" (getf option :short)) "") + (if (and (getf option :short) (getf option :takes-argument)) (format nil " ~A" (getf option :variable-name)) "") + (if (and (getf option :short) (getf option :long)) ", " "") + (if (getf option :long) (format nil "--~A" (getf option :long)) "") + (if (and (getf option :long) (getf option :takes-argument)) (format nil " ~A" (getf option :variable-name)) "") + (or (getf option :positional) ""))) + +(defun split-text (remaining-text width) + (if + (<= (length remaining-text) width) + (list remaining-text) + (let* + ((cr-point (position #\Newline remaining-text :end width)) + (space-point (position #\Space remaining-text :from-end t :end width)) + (split-point (or cr-point space-point))) + (when (not split-point) + (error "Couldn't split ~A due to word length" remaining-text)) + (cons + (subseq remaining-text 0 split-point) + (split-text (subseq remaining-text (1+ split-point)) width))))) + +(defun option-to-long-description (option left-column-width max-width) + (let + ((description (getf option :description)) + (available-width (- max-width left-column-width 4))) + (let + ((split-description (split-text description available-width)) + (option-string (option-string-for-long-description option))) + (format nil + (format nil " ~~A~~,,~A@A~~%~~{~~,,~A@A~~%~~}" + (+ 2 (- left-column-width (length option-string))) + (+ 4 left-column-width)) + option-string + (car split-description) + (cdr split-description))))) + +(defun options-to-description-string (options max-width) + (let + ((left-column-width (apply #'max (mapcar #'length (mapcar #'option-string-for-long-description options))))) + (format nil "~%Options:~{~%~A~}" (mapcar (lambda (option) (option-to-long-description option left-column-width max-width)) options)))) + +(defun reformat-description (description max-width) + (if + (zerop (length description)) + "" + (format nil "~{~A~%~}" + (split-text description max-width)))) + +; Just build out a reasonable default usage +; +; use sed --help as a base, that's reasonable enough +; split on whitespace, which is also reasonable enough +(defun usage (command options &optional (description "") (line-width 102)) + (mapcar (lambda (opt) (validate-option opt t)) options) + (format nil "~A~%~A~A~A" + (create-usage-line command options line-width) + (options-to-description-string options line-width) + (if (zerop (length description)) "" (format nil "~%")) + (reformat-description description line-width))) + +; helper functions +(defun option-present (option-name parsed-options) + (find option-name parsed-options :key #'car)) + +(defun option-argument (option-name parsed-options) + (cadr (assoc option-name parsed-options))) + +(defun option-arguments (option-name parsed-options) + (mapcar #'cadr (remove option-name parsed-options :key #'car :test-not #'eql)))