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

4 5 6 7 8 9 10 11 12 13 14
(defun success (&optional (success t))
  "Return magic values that signal success (default), or failure depending on SUCCESS"
  (if success
      (values t '#:success)
      (values nil '#:failure)))

(defun failure ()
  "Return magic values that signal failure"
  (success nil))


15
(defun re (arg)
16 17
  "Read-Eval function (the RE of REPL)
(the Print and Loop parts are not here)"
18 19
  (eval (read-from-string arg)))

20 21 22
(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."
23 24 25 26
  (block nil
    (flet ((try (x)
             (multiple-value-bind (sym foundp)
                 (find-symbol* (string-upcase x) :asdf-tools nil)
27
               (when (and sym (or earlyp (and foundp (fboundp sym))))
28
                 (return sym)))))
29 30
      (try (strcat "%" (string name))) ;; so that you may use load, t, etc., as targets
      (try name))))
31

32
(defun command-name (x &optional earlyp)
33
  "Given a command designator as per FIND-COMMAND, return the unix-y name for it, as a string"
34
  (let ((c (find-command x earlyp)))
35 36 37 38 39 40 41 42 43 44 45 46
    (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))))

47
(defun public-commands ()
48 49 50 51 52 53 54 55 56
  ;;(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
57 58
    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
59 60
    test-all-no-upgrade-no-stop test-all-no-stop
    check-all-scripts-results check-all-upgrade-results check-all-results
61
    make-archive make-and-publish-archive publish-archive link-archive archive install ;; release
62
    debian-package publish-debian-package
63
    re help show-commands makefile-targets)) ;; main
64

65 66 67 68
(defun public-command-strings ()
  (sort (mapcar 'command-name (public-commands)) 'string<))

(defun show-commands ()
69
  "print the (sorted list of) names of all the public commands of asdf-tools."
70
  (format t "~{~A~^ ~}~%" (public-command-strings))
71
  (success))
72 73

(defun makefile-targets ()
74 75 76
  "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"
77
  (let ((c (public-command-strings)))
78 79
    (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))
80
  (success))
81 82

(defun help (&optional x)
83
  "help about a command, or list of commands"
84 85
  (cond
    ((null x)
86
     (loop :for x :in (public-command-strings)
87
           :do (format t "~(~27A~)~@[  ~A~]~%"
88
                       x (short-function-description x)))
89
     (success))
90 91 92 93 94 95
    (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
96
                 (documentation x 'function))
97
         (success))))))
98

99 100
;;; Main entry point.
;;; NB: For access control, you could check that only exported symbols are used as entry points.
101
(defun process-arguments (args)
102 103 104 105 106
  (block nil
    (unless args
      (format t "No command provided~%")
      (return))
    (if-let ((fun (find-command (first args))))
107 108 109 110 111 112 113
      (let ((results (multiple-value-list (apply fun (rest args)))))
        ;; Don't print anything on success for regular commands, otherwise print all values returned.
        (cond
          ((equal results (multiple-value-list (success))))
          ((equal results (multiple-value-list (failure))) (format t "~&Command failed.~%"))
          (t (format t "~&~{~S~%~}" results)))
        (return (first results))))
114
    (format t "Command ~A not found~%" (first args))
115
    (return nil)))
116

117 118 119 120
;;; 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))
121 122

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