1.1--- a/lisp/lib/cli/clap/cmd.lisp Thu Sep 12 16:48:47 2024 -0400
1.2+++ b/lisp/lib/cli/clap/cmd.lisp Thu Sep 12 22:38:22 2024 -0400
1.3@@ -103,6 +103,9 @@
1.4 (defmethod active-cmds ((self cli-cmd))
1.5 (remove-if-not #'cli-lock-p (cli-cmds self)))
1.6
1.7+(defmethod activate-cmd ((self cli-cmd))
1.8+ (setf (cli-lock-p self) t))
1.9+
1.10 (defmethod find-opts ((self cli-cmd) name &key active recurse)
1.11 (let ((ret))
1.12 (flet ((%find (o obj)
1.13@@ -149,52 +152,45 @@
1.14 :kind slot, indicating the type of node and a :form slot which stores
1.15 a value."
1.16 (make-cli-ast
1.17- (let ((holes)) ;; list of arg indexes which can be skipped since they're
1.18- ;; consumed by an opt
1.19- (loop
1.20- for i below (length args)
1.21- for (a . args) on args
1.22- if (member i holes)
1.23- do (continue) ;; skip args which have been consumed already
1.24- ;; else
1.25- ;; if (= (length a) 1)
1.26- ;; collect (make-cli-node 'arg a) ; always treat single-char as arg
1.27- else
1.28- if (short-opt-p a) ;; SHORT OPT
1.29- collect
1.30- (if-let ((o (find-short-opts self (aref a 1) :recurse t)))
1.31- (%compose-short-opt (car o) a)
1.32- ;; TODO 2024-09-11: signal error?
1.33+ (loop
1.34+ with skip
1.35+ for i below (length args)
1.36+ for (a . args) on args
1.37+ if skip
1.38+ do (setq skip nil)
1.39+ else if (short-opt-p a) ;; SHORT OPT
1.40+ collect
1.41+ (if-let ((o (car (find-short-opts self (aref a 1) :recurse t))))
1.42+ (%compose-short-opt o)
1.43+ ;; TODO 2024-09-11: signal error?
1.44+ (with-opt-restart-case a
1.45+ (clap-unknown-argument a)))
1.46+ else if (long-opt-p a) ;; LONG OPT
1.47+ collect
1.48+ (let ((o (car (find-opts self (string-left-trim "-" a) :recurse t)))
1.49+ (has-eq (long-opt-has-eq-p a)))
1.50+ (cond
1.51+ ((and has-eq o)
1.52+ (setf (cli-opt-val o) (cdr has-eq))
1.53+ (make-cli-node 'opt o))
1.54+ ((and (not has-eq) o)
1.55+ (prog1
1.56+ (%compose-long-opt o (pop args))
1.57+ (setq skip t)))
1.58+ (t ;; (not o) (not has-eq)
1.59 (with-opt-restart-case a
1.60- (clap-unknown-argument a)))
1.61- else
1.62- if (long-opt-p a) ;; LONG OPT
1.63- collect
1.64- (let ((o (find-opts self (string-left-trim "-" a) :recurse t))
1.65- (has-eq (long-opt-has-eq-p a)))
1.66- (cond
1.67- ((and has-eq o)
1.68- (setf (cli-opt-val o) (cdr has-eq))
1.69- (make-cli-node 'opt o))
1.70- ((and (not has-eq) o)
1.71- (prog1 (%compose-long-opt (car o) args)
1.72- (push (1+ i) holes)))
1.73- (t ;; (not o) (not has-eq)
1.74- (with-opt-restart-case a
1.75- (clap-unknown-argument a)))))
1.76- ;; OPT GROUP
1.77- else
1.78- if (opt-group-p a)
1.79- collect nil
1.80- ;; CMD
1.81- else
1.82- collect
1.83- (let ((cmd (find-cmd self a)))
1.84- (if cmd
1.85- ;; TBD
1.86- (make-cli-node 'cmd (find-cmd self a))
1.87- ;; ARG
1.88- (make-cli-node 'arg a)))))))
1.89+ (clap-unknown-argument a)))))
1.90+ ;; OPT GROUP
1.91+ else if (opt-group-p a)
1.92+ collect (make-cli-node 'group nil)
1.93+ else ;; CMD or ARG
1.94+ collect
1.95+ (let ((cmd (find-cmd self a)))
1.96+ (if cmd
1.97+ ;; CMD
1.98+ (make-cli-node 'cmd cmd)
1.99+ ;; ARG
1.100+ (make-cli-node 'arg a))))))
1.101
1.102 (defmethod install-ast ((self cli-cmd) (ast cli-ast))
1.103 "Install the given AST, recursively filling in value slots."
1.104@@ -203,10 +199,10 @@
1.105 ;; itself is consumed. validation is performed in proc-args.
1.106
1.107 ;; before doing anything else we lock SELF, which should remain
1.108- ;; locked for the full runtime duration.
1.109- (setf (cli-lock-p self) t)
1.110+ ;; locked until all subcommands have completed
1.111+ (activate-cmd self)
1.112 (loop named install
1.113- for (node . tail) on (debug! (ast ast))
1.114+ for (node . tail) on (ast ast)
1.115 until (null node)
1.116 do
1.117 (let ((kind (cli-node-kind node)) (form (cli-node-form node)))
1.118@@ -259,4 +255,4 @@
1.119 (call-cmd self (cli-cmd-args self) (active-opts self))
1.120 (loop for c across (active-cmds self)
1.121 do (do-cmd c))))
1.122-
1.123+
2.1--- a/lisp/lib/cli/clap/opt.lisp Thu Sep 12 16:48:47 2024 -0400
2.2+++ b/lisp/lib/cli/clap/opt.lisp Thu Sep 12 22:38:22 2024 -0400
2.3@@ -42,14 +42,15 @@
2.4 (description nil :type (or null string))
2.5 (lock nil :type boolean))
2.6
2.7-(defun %compose-short-opt (o arg)
2.8- (declare (ignorable arg))
2.9+(defmethod activate-opt ((self cli-opt))
2.10+ (setf (cli-lock-p self) t))
2.11+
2.12+(defun %compose-short-opt (o)
2.13 (setf (cli-opt-val o) t)
2.14 (make-cli-node 'opt o))
2.15
2.16-(defun %compose-long-opt (o args)
2.17- (declare (ignorable args))
2.18- (setf (cli-opt-val o) (or (pop args) t))
2.19+(defun %compose-long-opt (o &optional val)
2.20+ (setf (cli-opt-val o) val)
2.21 (make-cli-node 'opt o))
2.22
2.23 (defmethod handle-unknown-argument ((self cli-opt) arg))
3.1--- a/lisp/lib/cli/clap/pkg.lisp Thu Sep 12 16:48:47 2024 -0400
3.2+++ b/lisp/lib/cli/clap/pkg.lisp Thu Sep 12 22:38:22 2024 -0400
3.3@@ -41,7 +41,9 @@
3.4 :handle-missing-arg
3.5 :handle-invalid-arg
3.6 :clap-missing-argument
3.7- :clap-invalid-argument))
3.8+ :clap-invalid-argument
3.9+ :activate-cmd
3.10+ :activate-opt))
3.11
3.12 (defpackage :cli/clap/ast
3.13 (:use :cl :std :log :dat/sxp)
3.14@@ -58,7 +60,8 @@
3.15 :parse-form-opt :parse-list-op :parse-sym-op :parse-key-op
3.16 :pasre-num-op :parse-file-op :parse-dir-op :cli
3.17 :cli-cd :with-cli :opts :cmds :debug-opts
3.18- :cli-opt :cli-cmd :cli-opt-val :cli-opt-lock :cli-opt-name))
3.19+ :cli-opt :cli-cmd :cli-opt-val :cli-opt-lock :cli-opt-name
3.20+ :active-cmds))
3.21
3.22 (defpackage :cli/clap/simple
3.23 (:use :cl :std :log :sb-ext)
4.1--- a/lisp/lib/cli/clap/proto.lisp Thu Sep 12 16:48:47 2024 -0400
4.2+++ b/lisp/lib/cli/clap/proto.lisp Thu Sep 12 22:38:22 2024 -0400
4.3@@ -41,6 +41,10 @@
4.4
4.5 (defgeneric active-opts (self &optional global))
4.6
4.7+(defgeneric activate-opt (self))
4.8+
4.9+(defgeneric activate-cmd (self))
4.10+
4.11 (defgeneric find-short-opts (self ch &key))
4.12
4.13 (defgeneric call-opt (self arg))
5.1--- a/lisp/lib/cli/clap/util.lisp Thu Sep 12 16:48:47 2024 -0400
5.2+++ b/lisp/lib/cli/clap/util.lisp Thu Sep 12 22:38:22 2024 -0400
5.3@@ -14,8 +14,8 @@
5.4
5.5 (defun long-opt-p (str)
5.6 (declare (simple-string str))
5.7- (and (char= (aref str 0) (aref str 1) #\-)
5.8- (> (length str) 2)))
5.9+ (and (> (length str) 2)
5.10+ (char= (aref str 0) (aref str 1) #\-)))
5.11
5.12 (defun long-opt-has-eq-p (str)
5.13 "Return non-nil if STR is a long-opt which has an '=' somewhere,
5.14@@ -27,8 +27,8 @@
5.15 (defun short-opt-p (str)
5.16 (declare (simple-string str))
5.17 (and (char= (aref str 0) #\-)
5.18- (not (char= (aref str 1) #\-))
5.19- (> (length str) 1)))
5.20+ (> (length str) 1)
5.21+ (not (char= (aref str 1) #\-))))
5.22
5.23 (defun opt-group-p (str)
5.24 (declare (simple-string str))
6.1--- a/lisp/lib/cli/multi.lisp Thu Sep 12 16:48:47 2024 -0400
6.2+++ b/lisp/lib/cli/multi.lisp Thu Sep 12 22:38:22 2024 -0400
6.3@@ -39,9 +39,9 @@
6.4 When you save an executable lisp image with this function you should
6.5 arrange for symlinks for each handled value of (ARG0) to be generated
6.6 ."
6.7- `(defmain (:exit ,exit :export ,export)
6.8- (string-case ((pathname-name (arg0)) :default ,default)
6.9- ,@mains)))
6.10+ `(cli/clap::defmain (:exit ,exit :export ,export)
6.11+ (string-case ((pathname-name (arg0)) :default ,default)
6.12+ ,@mains)))
6.13
6.14 (defun make-symlinks (src &optional directory &rest names)
6.15 "Make a set of symlinks from SRC to NAMES.
7.1--- a/lisp/lib/cli/pkg.lisp Thu Sep 12 16:48:47 2024 -0400
7.2+++ b/lisp/lib/cli/pkg.lisp Thu Sep 12 22:38:22 2024 -0400
7.3@@ -99,7 +99,7 @@
7.4 (:export :run-emacs :run-emacsclient :org-store-link))
7.5
7.6 (defpackage :cli/multi
7.7- (:use :cl :std :cli/clap :cli/repl)
7.8+ (:use :cl :std)
7.9 (:export
7.10 #:define-multi-main
7.11 #:make-symlinks))
