main.lisp 3.79 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 56 57 58 59 60 61 62 63
(defun public-command-strings ()
  (sort (mapcar 'command-name (public-commands)) 'string<))

(defun show-commands ()
  (format t "~{~A~^ ~}~%" (public-command-strings))
  (values))

(defun makefile-targets ()
  (let ((c (public-command-strings)))
    ;;(format t ".PHONY: ~{~A~^ ~}~%~%~{~A:~%~}~%" c c))
    (format t "~{~A:~%~}~%" c))
  (values))
64 65

(defun help (&optional x)
66
  "help about a command, or list of commands"
67 68
  (cond
    ((null x)
69
     (loop :for x :in (public-command-strings)
70
           :do (format t "~(~27A~)~@[  ~A~]~%"
71
                       x (short-function-description x)))
72
     (values))
73 74 75 76 77 78
    (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
79
                 (documentation x 'function))
80
         (values))))))
81

82 83 84 85 86 87 88 89 90 91 92 93
;;; 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))
94
        (return (or (null results) (first results))))) ;; Trick: (values) counts as T, not NIL.
95 96 97 98 99 100 101 102 103
    (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*)))