--- /dev/null
+(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)))
projects / opera / commitdiff