Coverage report: /home/ellis/comp/core/lib/cli/clap/cmd.lisp

Kind	Covered	All	%
expression	350	593	59.0
branch	26	72	36.1

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; cli/clap/cmd.lisp --- Clap Commands

2

3

;; Command Objects used to build CLI Applications.

4

5

;;; Commentary:

6

7

;; The main entry is PARSE-ARGS which is called with a CLI object and a list

8

;; of args. This in turns calls PROC-ARGS which does all of the parsing and

9

;; will recursively call PARSE-ARGS as needed on nested CLI objects. It also

10

;; sets the :LOCK slot on resulting objects, and returns a CLI-AST object. The

11

;; ast is installed into the CLI object at which point it can be executed with

12

;; DO-CMD.

13

14

;; DO-OPTS is called for each active (CLI-LOCK-P) CLI-OPT attached to a

15

;; CLI-CMD followed by a DO-CMD call in turn on each active CLI-CMD.

16

17

;;; Code:

18

(in-package :cli/clap/obj)

19

20

(defclass cli-cmd ()

21

;; name slot is required and must be a string

22

((name :initarg :name :initform (required-argument :name) :accessor cli-name :type string)

23

(opts :initarg :opts :initform (make-array 0 :element-type 'cli-opt :adjustable t)

24

:accessor opts :type (vector cli-opt))

25

(cmds :initarg :cmds :initform (make-array 0 :element-type 'cli-cmd :adjustable t)

26

:accessor cmds :type (vector cli-cmd))

27

(thunk :initform 'default-cmd-thunk :initarg :thunk :accessor cli-thunk :type symbol)

28

(lock :initform nil :initarg :lock :accessor cli-lock-p :type boolean)

29

(description :initarg :description :accessor cli-description :type string)

30

(args :initform nil :initarg :args :accessor cli-args))

31

(:documentation "CLI command class inherited by both the 'main' command which is executed when

32

a CLI is called without arguments, and all subcommands."))

33

34

(defmethod initialize-instance :after ((self cli-cmd) &key)

35

(with-slots (name thunk opts cmds) self

36

(unless (stringp name) (setf name (format nil "~(~A~)" name)))

37

(unless (vectorp cmds) (setf cmds (make-cmds cmds)))

38

(unless (vectorp opts) (setf opts (make-opts opts)))

39

self))

40

41

(defmethod make-load-form ((obj cli-cmd) &optional env)

42

(make-load-form-saving-slots

43

obj

44

:slot-names '(name opts cmds thunk lock description args)

45

:environment env))

46

47

(defmethod print-object ((self cli-cmd) stream)

48

(print-unreadable-object (self stream :type t)

49

(format stream "~A :active ~a :opts ~A :cmds ~A :args ~A"

50

(cli-name self)

51

(cli-lock-p self)

52

(length (opts self))

53

(length (cmds self))

54

(length (cli-args self)))))

55

56

(defmethod print-usage ((self cli-cmd) &optional stream)

57

(with-slots (opts cmds) self

58

(format stream "~(~A~)~:[~;*~]~24t~@[~A~]~@[~%~4t:doc ~A~]~@[~{~%~4t~A~^~}~]~@[~{~A~}~]"

59

(cli-name self)

60

(when *cli*

61

(equal (string (cli-thunk *cli*)) (string (cli-thunk self))))

62

(and (slot-boundp self 'description) (cli-description self))

63

(when (fboundp (cli-thunk self))

64

(documentation (symbol-function (cli-thunk self)) 'function))

65

(unless (null opts)

66

(loop for o across opts collect (with-output-to-string (s) (print-usage o s))))

67

(unless (null cmds)

68

               (loop for c across cmds collect (with-output-to-string (s) (print-usage c s)))))))

69

70

(defmethod print-help ((self cli-cmd) &optional stream)

71

(unless (typep self 'cli)

72

(print-usage self stream))

73

(let ((opts (opts self))

74

(cmds (cmds self)))

75

(unless (null opts)

76

(println "options:" stream)

77

(loop for o across opts

78

do (iprintln (with-output-to-string (s) (print-usage o s)) 2 stream)))

79

(terpri stream)

80

(unless (null cmds)

81

(println "commands:" stream)

82

(loop for c across cmds

83

do (iprintln (with-output-to-string (s) (print-usage c s)) 2 stream)))))

84

85

(defmethod push-cmd ((self cli-cmd) (place cli-cmd))

86

(vector-push self (cmds place)))

87

88

(defmethod push-opt ((self cli-opt) (place cli-cmd))

89

(vector-push self (opts place)))

90

91

(defmethod pop-cmd ((self cli-cmd))

92

(vector-pop (cmds self)))

93

94

(defmethod pop-opt ((self cli-opt))

95

(vector-pop (opts self)))

96

97

(defmethod equiv ((a cli-cmd) (b cli-cmd))

98

(with-slots (name opts cmds) a

99

(with-slots ((bn name) (bo opts) (bc cmds)) b

100

(and (string= name bn)

101

(if (and (null opts) (null bo))

102

t

103

(unless (member nil (loop for oa across opts

104

for ob across bo

105

collect (equiv oa ob)))

106

t))

107

(if (and (null cmds) (null bc))

108

t

109

(unless (member nil (loop for ca across cmds

110

for cb across bc

111

collect (equiv ca cb)))

112

t))))))

113

114

(defmethod find-cmd (name (self cli-cmd) &key active default)

115

(if-let ((c (find name (cmds self) :test 'equal :key 'cli-name)))

116

(if active

117

;; maybe issue warning here? report to user

118

(when (cli-lock-p c)

119

c)

120

c)

121

(if (eql default :error)

122

(error 'unknown-argument :name name :kind :cmd)

123

default)))

124

125

(defmethod (setf find-cmd) ((new cli-cmd) name (self cli-cmd))

126

(let ((match (find-cmd name self)))

127

(activate-cmd new)

128

(substitute new match (cmds self) :test 'equiv)))

129

130

(defmethod active-cmds ((self cli-cmd))

131

(remove-if-not #'cli-lock-p (cmds self)))

132

133

(defmethod activate-cmd ((self cli-cmd))

134

(setf (cli-lock-p self) t)

135

self)

136

137

(defmethod find-opts ((name string) (self cli-cmd) &key active recurse)

138

(let ((ret))

139

(flet ((%find (o obj)

140

(when-let ((found (find o (opts obj) :key #'cli-opt-name :test 'equal)))

141

(push found ret))))

142

(when (and recurse (cmds self))

143

(loop for c across (cmds self)

144

do (%find name c)))

145

(%find name self)

146

(when active

147

(setf ret (remove-if-not #'cli-lock-p ret)))

148

ret)))

149

150

(defmethod find-opt ((name string) (self cli-cmd) &key active default)

151

(if-let ((ret (find name (opts self) :key 'cli-opt-name :test 'equal)))

152

(if active

153

(when (cli-opt-lock ret) ret)

154

ret)

155

(if (eql default :error)

156

(error 'unknown-argument :name name :kind :opt)

157

default)))

158

159

(defun cli-name= (a b)

160

(equal (cli-name a) (cli-name b)))

161

162

(defmethod (setf find-opt) ((new cli-opt) (name string) (self cli-cmd))

163

(let ((match (find-opt name self)))

164

(activate-opt new)

165

(setf (opts self)

166

(substitute new match (opts self) :test 'equiv))))

167

168

(defmethod active-opts ((self cli-cmd))

169

(remove-if-not 'cli-opt-lock (opts self)))

170

171

(defun find-short-opts (flag cmd &key recurse)

172

"Find and return all CLI-OPTs matching character or string FLAG in CMD.

173

174

- recurse :: optionally check nested commands as well."

175

(let ((ret))

176

(flet ((%find (ch obj)

177

(when-let ((found (find (coerce ch 'character) obj

178

:key #'cli-opt-name

179

:test #'opt-string-prefix-eq)))

180

(push found ret))))

181

(flet ((%recurse-ch (ch vec)

182

(loop for c across vec

183

do (%find ch (opts c))))

184

(%recurse-str (str vec)

185

(loop for c across vec

186

for ch across str

187

do (%find ch (opts c)))))

188

(etypecase flag

189

(character

190

(when recurse (%recurse-ch flag (cmds cmd)))

191

(%find flag (opts cmd)))

192

(string

193

(when recurse (%recurse-str flag (cmds cmd)))

194

(%find flag (opts cmd))))

195

ret))))

196

197

(defun solop (self)

198

"A CLI object is considered 'solo' if there are no ACTIVE-CMDS parsed - there

199

are only OPTS and ARGS which should be used with the default command."

200

(= 0 (length (active-cmds self))))

201

202

(defmethod proc-args ((self cli-cmd) args)

203

"Process ARGS into an ast. Each element of the ast is a node with a

204

:kind slot, indicating the type of node and a :form slot which stores

205

an object."

206

(make-cli-ast

207

(flatten

208

(loop

209

with skip

210

with exit

211

for (a . args) on args

212

if skip

213

do (setq skip nil)

214

else if exit

215

do (loop-finish)

216

else if (short-opt-p a) ;; SHORT OPT

217

218

;; TODO 2025-01-01: handle opt-group-p

219

collect

220

(let* ((has-eq (short-opt-has-eq-p a))

221

(names (or (car has-eq) (string-left-trim "-" a)))

222

(opts (find-short-opts names self :recurse nil)))

223

(cond

224

((and (= (length opts) 1) (not has-eq))

225

(let ((o (car opts)))

226

(if (eql (cli-opt-kind o) 'boolean)

227

(%compose-flag-opt o)

228

(prog1

229

(%compose-value-opt o (pop args))

230

(setq skip t)))))

231

((and has-eq opts)

232

(loop for o in opts

233

do (activate-opt o)

234

do (setf (cli-opt-val o) (cdr has-eq))

235

collect (make-cli-node 'opt o)))

236

((and (not has-eq) opts)

237

(loop for o in opts

238

collect (%compose-flag-opt o)))

239

(t ;; if nothing else, we usually want to pass it as an arg, but

240

;; it may also be useful to enable the debugger and handle

241

;; with restarts.

242

(sb-ext:enable-debugger)

243

;; (with-opt-restart-case a

244

;; (clap-unknown-argument a 'cli-opt))

245

a)))

246

else if (long-opt-p a) ;; LONG OPT

247

collect

248

(let* ((has-eq (long-opt-has-eq-p a))

249

(name (or (car has-eq) (string-left-trim "-" a)))

250

(o (car (find-opts name self :recurse nil))))

251

(cond

252

((and has-eq o)

253

(activate-opt o)

254

(setf (cli-opt-val o) (cdr has-eq))

255

(make-cli-node 'opt o))

256

((and (not has-eq) o)

257

(prog1

258

(%compose-value-opt o (pop args))

259

(setq skip t)))

260

(t ;; (not o) (not has-eq)

261

(with-opt-restart-case a

262

(clap-unknown-argument a 'cli-opt)))))

263

;; OPT GROUP

264

else if (group-opt-p a)

265

collect

266

(make-cli-node 'group nil)

267

;; OPT KEYWORD (experimental)

268

else if (opt-keyword-p a)

269

collect (if-let ((o (car (find-opts (string-left-trim ":" a) self :recurse t))))

270

(prog1 (%compose-keyword-opt o (pop args))

271

(setq exit t))

272

(make-cli-node 'arg a))

273

else ;; CMD or ARG

274

collect

275

(if-let ((cmd (find-cmd a self)))

276

(progn (setq exit t)

277

;; command forms are another AST

278

(setf cmd (parse-args cmd args))

279

(make-cli-node 'cmd cmd))

280

;; just a plain arg - move to next

281

(make-cli-node 'arg a))))))

282

283

(defmethod install-ast ((self cli-cmd) (ast cli-ast))

284

"Install the given AST, recursively filling in value slots."

285

;; we assume all nodes in the ast have been validated and the ast

286

;; itself is consumed. validation is performed in proc-args.

287

288

;; before doing anything else we lock SELF, which should remain

289

;; locked until all subcommands have completed

290

(activate-cmd self)

291

(loop named install

292

for (node . tail) on (ast ast)

293

while node

294

do

295

(let ((kind (cli-node-kind node))

296

(form (cli-node-form node)))

297

(case kind

298

;; opts

299

(opt

300

(setf (find-opt (cli-name form) self) form))

301

(cmd

302

(setf (find-cmd (cli-name form) self) form))

303

(arg (push-arg form self)))))

304

(setf (cli-args self) (nreverse (cli-args self)))

305

self)

306

307

(defmethod install-thunk ((self cli-cmd) (lambda function) &optional compile)

308

"Install THUNK into the corresponding slot in cli-cmd SELF."

309

(let ((%thunk (if compile (compile nil lambda) lambda)))

310

(setf (cli-thunk self) %thunk)

311

self))

312

313

(defmethod push-arg (arg (self cli-cmd))

314

"Push an ARG onto the corresponding slot of a CLI-CMD."

315

(push arg (cli-args self)))

316

317

(defmethod parse-args ((self cli-cmd) args &key (install t))

318

"Parse ARGS and return the updated object SELF.

319

ARGS is assumed to be a valid cli-ast (list of cli-nodes), unless COMPILE is

320

t, in which case a list of strings is assumed. INSTALL always implies COMPILE

321

and calls INSTALL-AST on SELF with ARGS."

322

(let ((ast (proc-args self args)))

323

(if install

324

(install-ast self ast)

325

ast)

326

self))

327

328

;; WARNING: make sure to fill in the opt and cmd slots with values

329

;; from the top-level args before calling a command.

330

(defmethod call-cmd ((self cli-cmd) args opts)

331

(log:trace! "calling command: ~A~%:args ~A~%:opts ~A~%" self args opts)

332

(funcall (cli-thunk self) args opts))

333

334

(defmethod do-opts ((self cli-cmd))

335

(do-opts (active-opts self)))

336

337

(defmethod do-cmd ((self cli-cmd))

338

"Perform the active command or subcommand, recursively calling DO-CMD on

339

subcommands until a level is reached which satisfies SOLOP. active OPTS are

340

evaluated with DO-OPTS along the way."

341

(do-opts self)

342

(if (solop self)

343

(call-cmd self (cli-args self) (active-opts self))

344

;; release opts

345

;; (loop for o across (active-opts self)

346

;; do (setf (cli-opt-lock o) nil)))

347

(loop for c across (active-cmds self)

348

do (do-opts c)

349

do (call-cmd c (cli-args c) (active-opts c))

350

do (setf (cli-lock-p c) nil)))

351

(setf (cli-lock-p self) nil))