Mercurial > core / lisp/lib/cli/clap/cli.lisp
changeset 688: |
517c65b51e6b |
parent: |
c5fe76568de0
|
child: |
2e7d93b892a5 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Tue, 01 Oct 2024 21:52:17 -0400 |
permissions: |
-rw-r--r-- |
description: |
clap tests |
1 ;;; cli/clap/cli.lisp --- Clap CLI Class 3 ;; Top-level command object of a CLI App 6 (in-package :cli/clap/obj) 8 (defun make-cli (kind &rest slots) 9 "Creates a new CLI object of the given kind." 10 (declare (type (member :opt :cmd :cli t) kind)) 12 ((eql kind :cli) (apply #'make-instance 'cli slots)) 13 ((eql kind :opt) (apply #'make-cli-opt slots)) 14 ((eql kind :cmd) (apply #'make-instance 'cli-cmd slots)) 15 (t (apply #'make-instance kind slots)))) 17 (defmacro define-cli (sym &key name version #+nil (help t) description thunk opts cmds) 18 "Define a symbol NAME bound to a top-level CLI object." 19 (with-gensyms (%name %class) 26 `(,*default-cli-def* ,%name (make-cli ,%class :name ,name 28 :description ,description 30 :opts ,(make-opts opts) 31 :cmds ,(make-cmds cmds))))) 33 (defmacro defmain (name (&key (exit t)) &body body) 34 "Define a CLI main function in the current package." 35 `(let ((*no-exit* ,(not exit))) 37 "Run the top-level function and print to *STDOUT*." 42 ;; RESEARCH 2023-09-12: closed over hash-table with short/long flags 43 ;; to avoid conflicts. if not, need something like a flag-function 44 ;; slot at class allocation. 45 (defun make-opts (opts) 46 "Make a vector of CLI-OPTs based on OPTS." 50 (string (make-cli-opt :name x)) 51 (list (apply #'make-cli :opt x)))) 54 (defun make-cmds (cmds) 55 "Make a vector of CLI-CMDs based on CMDS." 60 (string (make-cli :cmd :name x)) 61 (list (apply #'make-cli :cmd x)) 62 (t (make-cli :cmd :name (format nil "~(~A~)" x))))) 65 (defclass cli (cli-cmd) 66 ;; name slot defaults to *package*, must be string 67 ((name :initarg :name :initform (string-downcase (package-name *package*)) :accessor cli-name :type string) 68 (version :initarg :version :initform "0.1.0" :accessor cli-version :type string) 69 ;; TODO 2023-10-11: look into pushd popd - cd-stack? 70 (cd :initarg :cd :initform (sb-posix:getcwd) :type string :accessor cli-cd 71 :documentation "working directory of the top-level CLI.")) 72 (:documentation "CLI")) 74 (defmethod print-usage ((self cli) &optional stream) 75 (iprintln (format nil "usage: ~A [opts] <command> [<arg>]~%" (cli-name self)) 2 stream)) 77 (defmethod print-version ((self cli) &optional stream) 78 (println (cli-version self) stream)) 80 (defmethod print-help ((self cli) &optional (stream t)) 81 (println (format nil "~A v~A --- ~A~%" (cli-name self) (cli-version self) (cli-description self)) stream) 82 (print-usage self stream) 84 (println "options:" stream) 85 (with-slots (opts cmds) self 87 (loop for o across opts 88 do (iprintln (print-usage o nil) 2 stream))) 90 (println "commands:" stream) 92 (loop for c across cmds 93 do (iprintln (print-usage c nil) 2 stream))))) 95 (defmethod cli-equal :before ((a cli) (b cli)) 96 "Return T if A is the same cli object as B. 98 Currently this function is intended only for instances of the CLI 99 class and is used as a specialized EQL for DEFINE-CONSTANT." 100 (with-slots (version) a 101 (with-slots ((bv version)) b 102 (string= version bv)))) 104 (declaim (inline debug-opts)) 105 (defun debug-opts (cli) 106 (let ((o (active-opts cli)) 108 (c (active-cmds cli))) 109 (log:debug! :pwd (cli-cd cli) :active-opts o :cmd-args a :active-cmds c))) 111 (defmacro with-cli ((cli &rest slots) args &body body) 112 "Like with-slots with some extra bindings. 114 SLOTS is a list passed to WITH-SLOTS. 116 CLI is updated based on the current environment and dynamically bound 117 to *CLI*. ARGS is a list of CLI args, defaults to *POSIX-ARGV* at 121 (setf (cli-cd *cli*) *default-pathname-defaults*) 122 (with-slots ,slots (parse-args *cli* ,args :compile t)