main.lisp 4.57 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 10 11
(defun find-command (name &optional earlyp)
  "Given a string NAME, find the symbol for the function that implements the command, or else NIL.
Unless EARLYP is true, return NIL if the symbol is not fbound."
12 13 14 15
  (block nil
    (flet ((try (x)
             (multiple-value-bind (sym foundp)
                 (find-symbol* (string-upcase x) :asdf-tools nil)
16
               (when (and sym (or earlyp (and foundp (fboundp sym))))
17
                 (return sym)))))
18 19
      (try (strcat "%" (string name))) ;; so that you may use load, t, etc., as targets
      (try name))))
20

21
(defun command-name (x &optional earlyp)
22
  "Given a command designator as per FIND-COMMAND, return the unix-y name for it, as a string"
23
  (let ((c (find-command x earlyp)))
24 25 26 27 28 29 30 31 32 33 34 35
    (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))))

36
(defun public-commands ()
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
44
    test %t test-scripts ;; test-scripts
45
    test-upgrade u extract-tagged-asdf extract-all-tagged-asdf extract ;; test-upgrade
46 47
    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
48 49
    test-all-no-upgrade-no-stop test-all-no-stop
    check-all-scripts-results check-all-upgrade-results check-all-results
50
    make-archive make-and-publish-archive publish-archive link-archive archive install ;; release
51
    debian-package publish-debian-package
52
    re help show-commands makefile-targets)) ;; main
53

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

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

(defun makefile-targets ()
63 64 65
  "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"
66
  (let ((c (public-command-strings)))
67 68
    (format t ".PHONY: ~{~A~^ ~}~%~%~{~A~^ ~}: force
	./tools/asdf-tools env l='$l' L='$L' u='$u' U='$u' v='$v' s='$s' t='$t' $@~%" c c))
69
  (success))
70 71

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

88 89
;;; Main entry point.
;;; NB: For access control, you could check that only exported symbols are used as entry points.
90
(defun process-arguments (args)
91 92 93 94 95 96 97 98 99 100 101 102
  (if-let ((fun (and args (find-command (first args)))))
    (let ((results (multiple-value-list (apply fun (rest args)))))
      ;; Don't print anything on success for regular commands, otherwise print all values returned.
      (if (failurep results)
          (format t "~&Failure:~{~& ~A~}~&" (failure-failures results))
          (format t "~{~&~S~&~}" (if (successp results) (success-values results) results)))
      (apply 'values results))
    (progn
      (if args
        (format t "Command ~A not found~%" (first args))
        (format t "No command provided~%"))
      nil)))
103

104 105 106 107
;;; For a multi-call binary, use these cl-launch or buildapp arguments: --dispatch-entry asdf-tools/asdf-tools::main
(defun main (argv)
  (initialize-environment)
  (process-arguments argv))
108 109

(defun entry-point ()
110
  (main *command-line-arguments*))