main.lisp 3.46 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 51 52 53
    re help)) ;; main


(defun help (&optional x)
54
  "help about a command, or list of commands"
55 56
  (cond
    ((null x)
57
     (loop :for x :in (sort (public-commands) 'string< :key 'command-name)
58
           :do (format t "~(~27A~)~@[  ~A~]~%"
59
                       (command-name x) (short-function-description x)))
60
     (values))
61 62 63 64 65 66
    (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
67
                 (documentation x 'function))
68
         (values))))))
69

70 71 72 73 74 75 76 77 78 79 80 81
;;; 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))
82
        (return (or (null results) (first results))))) ;; Trick: (values) counts as T, not NIL.
83 84 85 86 87 88 89 90 91
    (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*)))