Mercurial > core / lisp/lib/cli/clap/cmd.lisp
changeset 698: |
96958d3eb5b0 |
parent: |
517c65b51e6b
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Fri, 04 Oct 2024 22:04:59 -0400 |
permissions: |
-rw-r--r-- |
description: |
fixes |
1 ;;; cli/clap/cmd.lisp --- Clap Commands 3 ;; Command Objects used to build CLI Applications. 10 (in-package :cli/clap/obj) 13 ;; name slot is required and must be a string 14 ((name :initarg :name :initform (required-argument :name) :accessor cli-name :type string) 15 (opts :initarg :opts :initform (make-array 0 :element-type 'cli-opt :adjustable t) 16 :accessor opts :type (vector cli-opt)) 17 (cmds :initarg :cmds :initform (make-array 0 :element-type 'cli-cmd :adjustable t) 18 :accessor cmds :type (vector cli-cmd)) 19 (thunk :initform 'default-thunk :initarg :thunk :accessor cli-thunk :type symbol) 20 (lock :initform nil :initarg :lock :accessor cli-lock-p :type boolean) 21 (description :initarg :description :accessor cli-description :type string) 22 (args :initform nil :initarg :args :accessor cli-args)) 23 (:documentation "CLI command class inherited by both the 'main' command which is executed when 24 a CLI is called without arguments, and all subcommands.")) 26 (defmethod initialize-instance :after ((self cli-cmd) &key) 27 (with-slots (name thunk opts cmds) self 28 (unless (stringp name) (setf name (format nil "~(~A~)" name))) 29 (unless (vectorp cmds) (setf cmds (make-cmds cmds))) 30 (unless (vectorp opts) (setf opts (make-opts opts))) 33 (defmethod make-load-form ((obj cli-cmd) &optional env) 34 (make-load-form-saving-slots 36 :slot-names '(name opts cmds thunk lock description args) 39 (defmethod print-object ((self cli-cmd) stream) 40 (print-unreadable-object (self stream :type t) 41 (format stream "~A :active ~a :opts ~A :cmds ~A :args ~A" 46 (length (cli-args self))))) 48 (defmethod print-usage ((self cli-cmd) &optional stream) 49 (with-slots (opts cmds) self 50 (format stream "~(~A~) ~A~A~A" 52 (if-let ((d (and (slot-boundp self 'description) (cli-description self)))) 57 (format nil "~{~% ~A~^~}" (loop for o across opts collect (print-usage o nil)))) 60 (format nil "~{!~A~}" (loop for c across cmds collect (print-usage c nil))))))) 62 (defmethod push-cmd ((self cli-cmd) (place cli-cmd)) 63 (vector-push self (cmds place))) 65 (defmethod push-opt ((self cli-opt) (place cli-cmd)) 66 (vector-push self (opts place))) 68 (defmethod pop-cmd ((self cli-cmd)) 69 (vector-pop (cmds self))) 71 (defmethod pop-opt ((self cli-opt)) 72 (vector-pop (opts self))) 74 (defmethod handle-unknown-opt ((self cli-cmd) (opt string)) 75 (with-opt-restart-case opt 76 (clap-unknown-argument opt 'cli-opt))) 78 (defmethod handle-invalid-opt ((self cli-cmd) (opt string) &optional reason) 79 (clap-invalid-argument opt :kind 'cli-opt :reason reason)) 81 (defmethod handle-missing-opt ((self cli-cmd) (opt string)) 82 (clap-missing-argument opt 'cli-opt)) 84 (defmethod cli-equal ((a cli-cmd) (b cli-cmd)) 85 (with-slots (name opts cmds) a 86 (with-slots ((bn name) (bo opts) (bc cmds)) b 87 (and (string= name bn) 88 (if (and (null opts) (null bo)) 90 (unless (member nil (loop for oa across opts 92 collect (cli-equal oa ob))) 94 (if (and (null cmds) (null bc)) 96 (unless (member nil (loop for ca across cmds 98 collect (cli-equal ca cb))) 101 (defmethod find-cmd ((self cli-cmd) name &optional active) 102 (when-let ((c (find name (cmds self) :key #'cli-name :test #'string=))) 104 ;; maybe issue warning here? report to user 109 (defmethod (setf find-cmd) ((new cli-cmd) (self cli-cmd) name &optional active) 110 (let ((match (find-cmd self name active) )) 111 (substitute new match (cmds self) :test 'cli-equal))) 113 (defmethod active-cmds ((self cli-cmd)) 114 (remove-if-not #'cli-lock-p (cmds self))) 116 (defmethod activate-cmd ((self cli-cmd)) 117 (setf (cli-lock-p self) t)) 119 (defmethod find-opts ((self cli-cmd) name &key active recurse) 121 (flet ((%find (o obj) 122 (when-let ((found (find o (opts obj) :key #'cli-opt-name :test 'equal))) 124 (when (and recurse (cmds self)) 125 (loop for c across (cmds self) 129 (setf ret (remove-if-not #'cli-lock-p ret))) 132 (defmethod find-opt ((self cli-cmd) name &optional active) 133 (let ((ret (find name (opts self) :key #'cli-opt-name :test 'equal))) 135 (when (cli-opt-lock ret) ret) 138 (defmethod (setf find-opt) ((new cli-opt) (self cli-cmd) name &optional active) 139 (let ((match (find-opt self name active))) 140 (substitute new match (opts self) :test 'cli-equal))) 142 (defmethod active-opts ((self cli-cmd)) 143 (remove-if-not 'cli-opt-lock (opts self))) 145 (defmethod find-short-opts ((self cli-cmd) ch &key recurse) 147 (flet ((%find (ch obj) 148 (when-let ((found (find ch (opts obj) :key #'cli-opt-name :test #'opt-string-prefix-eq))) 150 (when (and recurse (cmds self)) 151 (loop for c across (cmds self) 156 (declaim (inline solop)) 158 (= 0 (length (active-cmds self)) (length (active-opts self)))) 160 (defmacro with-opt-restart-case (arg condition) 161 "Bind restarts 'use-as-arg' and 'discard-arg' for duration of BODY." 162 `(restart-case ,condition 163 (use-as-arg () () (make-cli-node 'arg ,arg)) 164 (discard-arg () () (setf ,arg nil)))) 166 (defmethod proc-args ((self cli-cmd) args) 167 "Process ARGS into an ast. Each element of the ast is a node with a 168 :kind slot, indicating the type of node and a :form slot which stores 174 for (a . args) on args 179 ;; TODO 2024-09-15: handle flag groups -abcd 180 else if (short-opt-p a) ;; SHORT OPT 182 (if-let ((o (car (find-short-opts self (aref a 1) :recurse nil)))) 183 (%compose-short-opt o) 184 (with-opt-restart-case a 185 (clap-unknown-argument a 'cli-opt))) 186 else if (long-opt-p a) ;; LONG OPT 188 (let* ((has-eq (long-opt-has-eq-p a)) 189 (name (or (car has-eq) (string-left-trim "-" a))) 190 (o (car (find-opts self name :recurse nil)))) 193 (setf (cli-opt-val o) (cdr has-eq)) 194 (make-cli-node 'opt o)) 195 ((and (not has-eq) o) 197 (%compose-long-opt o (pop args)) 199 (t ;; (not o) (not has-eq) 200 (with-opt-restart-case a 201 (clap-unknown-argument a 'cli-opt))))) 203 else if (opt-group-p a) 205 (make-cli-node 'group nil) 206 ;; OPT KEYWORD (experimental) 207 else if (opt-keyword-p a) 208 collect (if-let ((o (car (find-opts self (string-left-trim ":" a) :recurse nil)))) 209 (prog1 (%compose-keyword-opt o (pop args)) 211 (make-cli-node 'arg a)) 214 (if-let ((cmd (find-cmd self a))) 215 (prog1 (make-cli-node 'cmd (parse-args cmd args :compile t)) 217 ;; just a plain arg - move to next 218 (make-cli-node 'arg a))))) 220 (defmethod install-ast ((self cli-cmd) (ast cli-ast)) 221 "Install the given AST, recursively filling in value slots." 222 (with-slots (cmds opts) self 223 ;; we assume all nodes in the ast have been validated and the ast 224 ;; itself is consumed. validation is performed in proc-args. 226 ;; before doing anything else we lock SELF, which should remain 227 ;; locked until all subcommands have completed 230 for (node . tail) on (ast ast) 233 (let ((kind (cli-node-kind node)) 234 (form (cli-node-form node))) 238 (setf #1=(find-opt self (cli-name form)) form) 240 (log:trace! (format nil "installing opt ~A" (cli-name form)))) 242 (setf (find-cmd self (cli-name form)) form) 243 (log:trace! (format nil "installing cmd ~A" (cli-name form)))) 244 (arg (push-arg form self))))) 245 (setf (cli-args self) (nreverse (cli-args self))) 248 (defmethod install-thunk ((self cli-cmd) (lambda function) &optional compile) 249 "Install THUNK into the corresponding slot in cli-cmd SELF." 250 (let ((%thunk (if compile (compile nil lambda) lambda))) 251 (setf (cli-thunk self) %thunk) 254 (defmethod push-arg (arg (self cli-cmd)) 255 "Push an ARG onto the corresponding slot of a CLI-CMD." 256 (push arg (cli-args self))) 258 (defmethod parse-args ((self cli-cmd) args &key (compile t)) 259 "Parse ARGS and return the updated object SELF. 260 ARGS is assumed to be a valid cli-ast (list of cli-nodes), unless COMPILE is 261 t, in which case a list of strings is assumed." 262 (with-slots (opts cmds) self 263 (let ((args (if compile (proc-args self args) args))) 264 (install-ast self args)))) 266 ;; WARNING: make sure to fill in the opt and cmd slots with values 267 ;; from the top-level args before calling a command. 268 (defmethod call-cmd ((self cli-cmd) args opts) 269 (trace! "calling command:" args opts) 270 (funcall (cli-thunk self) args opts)) 272 (defmethod do-opts ((self cli-cmd)) 273 (do-opts (active-opts self))) 275 (defmethod do-cmd ((self cli-cmd)) 276 "Perform the active command or subcommand, recursively calling DO-CMD on 277 subcommands until a level is reached which satisfies SOLOP. active OPTS are 278 evaluated with DO-OPTS along the way." 281 (prog1 (call-cmd self (cli-args self) (active-opts self)) 283 (loop for o across (active-opts self) 284 do (setf (cli-opt-lock o) nil))) 285 (loop for c across (active-cmds self) 287 (setf (cli-lock-p self) nil))