main.lisp 4.05 KB
Newer Older
1 2 3 4
;;;; Generic code to interface a Lisp script to the shell command-line.
(in-package :asdf-tools)

(defun re (arg)
5 6
  "Read-Eval function (the RE of REPL)
(the Print and Loop parts are not here)"
7 8
  (eval (read-from-string arg)))

9
(defun find-command (x &optional earlyp)
10
  "Find the function for an asdf-tools command by name"
11 12 13 14
  (block nil
    (flet ((try (x)
             (multiple-value-bind (sym foundp)
                 (find-symbol* (string-upcase x) :asdf-tools nil)
15
               (when (and sym (or earlyp (and foundp (fboundp sym))))
16 17
                 (return sym)))))
      (try (strcat "%" (string x))) ;; so that you may use load, t, etc., as targets
18 19
      (try x))))

20 21
(defun command-name (x &optional earlyp)
  (let ((c (find-command x earlyp)))
22 23 24 25 26 27 28 29 30 31 32 33
    (when c
      (let ((s (string-downcase c)))
        (if (eql (first-char s) #\%) (subseq s 1) s)))))

(defun short-function-description (x)
  "Short function description for x"
  (when (stringp x) (setf x (find-command x)))
  (if-let ((doc (and x (documentation x 'function))))
    (let* ((first-line (with-input (s doc) (read-line s)))
           (len (length first-line)))
      (if (>= len 50) (strcat (subseq first-line 0 49) "…") first-line))))

34
(defun public-commands ()
35 36 37 38 39 40 41 42 43
  ;;(loop :for x :being :the :external-symbols :of :asdf-tools
  ;; :when (and (eq x (find-command x)) (documentation x 'function)) :collect x)
  '(build-asdf doc website wc ;; build
    clean %push merge-master-into-release fix-local-git-tags fix-remote-git-tags ;; git
    git-all-committed-p
    bump-version bump ;; version
    test-load-systems test-clean-load test-basic %load install-asdf ;; test-basic
    %test %t test-scripts ;; test-scripts
    test-upgrade u extract-tagged-asdf extract-all-tagged-asdf extract ;; test-upgrade
44 45
    test-all-clean-load test-all-scripts test-all-no-upgrade test-all-upgrade ;; test-all
    test-all test-all-scripts-no-stop test-all-upgrade-no-stop
46 47
    test-all-no-upgrade-no-stop test-all-no-stop
    check-all-scripts-results check-all-upgrade-results check-all-results
48 49
    make-archive publish-archive link-archive archive install ;; release
    debian-package publish-debian-package
50
    re help show-commands makefile-targets)) ;; main
51

52 53 54 55
(defun public-command-strings ()
  (sort (mapcar 'command-name (public-commands)) 'string<))

(defun show-commands ()
56
  "print the (sorted list of) names of all the public commands of asdf-tools."
57 58 59 60
  (format t "~{~A~^ ~}~%" (public-command-strings))
  (values))

(defun makefile-targets ()
61 62 63
  "print declaration for the public commands of asdf-tools as as many Makefile targets
so that, when included in the Makefile, they will enable shell completion
based on a list of targets"
64 65 66 67
  (let ((c (public-command-strings)))
    ;;(format t ".PHONY: ~{~A~^ ~}~%~%~{~A:~%~}~%" c c))
    (format t "~{~A:~%~}~%" c))
  (values))
68 69

(defun help (&optional x)
70
  "help about a command, or list of commands"
71 72
  (cond
    ((null x)
73
     (loop :for x :in (public-command-strings)
74
           :do (format t "~(~27A~)~@[  ~A~]~%"
75
                       x (short-function-description x)))
76
     (values))
77 78 79 80 81 82
    (t
     (let ((x (find-command x)))
       (when x
         (format t "~A~@[ ~A~]~%~@[~A~]~&"
                 (command-name x)
                 (or ()) ;; TODO: remember the arguments to deftestcmd, translate to v=, etc
83
                 (documentation x 'function))
84
         (values))))))
85

86 87 88 89 90 91 92 93 94 95 96 97
;;; Main entry point.
;;; NB: For access control, you could check that only exported symbols are used as entry points.
(defun main (args)
  (block nil
    (unless args
      (format t "No command provided~%")
      (return))
    (if-let ((fun (find-command (first args))))
      (let ((results
              (multiple-value-list (apply fun (rest args)))))
        (when results
          (format t "~&~{~S~%~}" results))
98
        (return (or (null results) (first results))))) ;; Trick: (values) counts as T, not NIL.
99 100 101 102 103 104 105 106 107
    (format t "Command ~A not found~%" (first args))
    (return)))


(defun entry-point ()
  (setf *lisp-interaction* nil)
  (uiop:with-fatal-condition-handler ()
    (initialize-environment)
    (main *command-line-arguments*)))