test-program.script 6.04 KB
Newer Older
1
;;; -*- Lisp -*-
2 3
(DBG :foo (current-lisp-file-pathname))

4
(unless (or #+(or allegro (and clisp os-unix) clozure cmucl (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl scl) t)
5
  (DBG "Creating images is not supported on your CL implementation")
6 7
  (leave-test "Skipping test" 0))

8 9 10 11 12 13 14 15 16 17 18 19 20 21
#+(and sbcl openbsd)
(let ((version (run-program "uname -r" :output '(:string :stripped t))))
  (when (version-satisfies version "6.0")
    (DBG "Running on OpenBSD >=6.0. Checking this partition for wxallowed.")
    (let* ((df-line (second (uiop:run-program
                             (list "df" "-P" (native-namestring *build-directory*))
                             :output :lines)))
           (device (first (split-string df-line))))
      (dolist (mount-line (uiop:run-program "mount" :output :lines))
        (let ((mount-device (first (split-string mount-line))))
          (when (and (string= device mount-device)
                     (not (search "wxallowed" mount-line)))
            (leave-test "Skipping test: wxallowed not set" 0)))))))

22
(assert (find-system :hello-world-example))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
23

24
;; Try to load lisp-invocation from xcvb
25 26 27 28 29 30
(initialize-source-registry
 `(:source-registry
   (:directory ,*asdf-directory*)
   (:directory (,*asdf-directory* "uiop/"))
   (:tree (,*asdf-directory* "ext/"))
   :inherit-configuration))
31
(unless (find-system :lisp-invocation nil)
32
  (leave-test "Couldn't find lisp-invocation. Probably your ASDF ext/ directory needs submodule update." 1))
33
(unless (version-satisfies (find-system "lisp-invocation") "1.0.12")
34
  (leave-test "Lisp-invocation library isn't new enough to test successfully. Probably your ASDF ext/ directory needs submodule update." 1))
35
(load-system "lisp-invocation/all")
36 37 38
;; Disable any user source registry.
(initialize-source-registry `(:source-registry :ignore-inherited-configuration))

39 40 41 42
(defun make-hello-world (kind)
  (assert-equal
   0
   (nth-value 2
43
    (lisp-invocation:invoke-lisp
44
     :implementation-type (lisp-invocation/allegro-variants:current-lisp-variant)
45 46
     :cross-compile nil
     :load (native-namestring (subpathname *test-directory* "make-hello-world.lisp"))
47
     :eval (format nil "(asdf-test::make-hello-~(~a~))" kind)
48 49 50 51
     :run-program-args
     `(:input nil :ignore-error-status t
       :output (,*standard-output* :linewise t :prefix "stdout: ")
       :error-output (,*error-output* :linewise t :prefix "stderr: "))))))
52

53 54 55 56 57 58 59
(progn
  (DBG "test image-op")
  (defparameter img (output-file (make-operation 'image-op) (find-system :hello-world-example)))
  (assert (absolute-pathname-p img))
  (delete-file-if-exists img)
  (DBG "- first create an executable image")
  (make-hello-world 'image)
60
  #+cmucl
61 62
  (unless (probe-file* img)
    (leave-test "CMUCL seemingly can't find the 32-bit compiler and libraries required to dump images. Aborting test." 0))
63
  (assert (probe-file* img) () "Can't find image file ~S" img)
64

65
  (DBG "- then use this executable image")
66 67 68
  (assert-equal
   (nest
    #+lispworks (last)
69
    (lisp-invocation:invoke-lisp
70
     :implementation-type (lisp-invocation/allegro-variants:current-lisp-variant)
71 72 73 74
     :cross-compile nil
     :image-path (native-namestring img)
     :eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)"
     :run-program-args '(:output :lines :error-output t)))
75
   '("hello, world"))
76

77
  (DBG "- now, use this executable image with arguments")
78 79
  #-(or lispworks scl) ;; These can't be passed arguments the normal way
  (assert-equal
80
   (lisp-invocation:invoke-lisp
81
    :implementation-type (lisp-invocation/allegro-variants:current-lisp-variant)
82 83 84 85 86
    :image-path (native-namestring img)
    :cross-compile nil
    :eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)"
    :arguments '("a" "b c" "d")
    :run-program-args '(:output :lines :error-output t))
87 88 89 90 91
   '("hello, world"
     "You passed 3 arguments:"
     "  \"a\""
     "  \"b c\""
     "  \"d\"")))
92

93 94 95
(progn
  (DBG "test program-op")
  (unless (or #+(or clisp clozure (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl) t
96
              #+cmucl nil ;; uncomment if you have 32-bit gcc support - or can autodetect
97 98 99 100 101
              #+clisp (version-satisfies
                       (first (split-string (lisp-implementation-version) :separator " "))
                       "2.48"))
    (DBG "Creating standalone programs is not supported on your CL implementation")
    (leave-test "Skipping test" 0))
102

103 104 105 106 107 108
  (defparameter exe (output-file (make-operation 'program-op) (find-system :hello-world-example)))
  (assert (absolute-pathname-p exe))
  (delete-file-if-exists exe)
  (DBG "- first, create the standalone program")
  (make-hello-world 'program)
  (assert (probe-file* exe) () "Can't find executable file ~S" exe)
109

110
  (DBG "- use that standalone program")
111 112
  (assert-equal (run-program `(,(native-namestring exe)) :output :lines :error-output t)
                '("hello, world"))
113

114
  (DBG "- use that standalone program with arguments")
115 116 117 118 119 120
  (assert-equal (run-program `(,(native-namestring exe) "a" "b c" "d") :output :lines :error-output t)
                '("hello, world"
                  "You passed 3 arguments:"
                  "  \"a\""
                  "  \"b c\""
                  "  \"d\"")))
121

122 123 124
#+(or ecl mkcl)
(progn
  (DBG "Now create an program without UIOP")
125 126
  (assert (probe-file (asdf/bundle::system-module-pathname "asdf")))
  (assert (probe-file (asdf/bundle::system-module-pathname "cmp")))
127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142
  (def-test-system hello-no-uiop
    :class program-system
    :no-uiop t
    :components ((:file "file1"))
    :epilogue-code
    (progn
      (format t "~:[Look ma, no UIOP~;Oops, UIOP~]!~%" (find-package :uiop))
      (format t "~:[But no TEST-PACKAGE :-(~;But TEST-PACKAGE~]!~%" (find-package :test-package))
      #+ecl (si:quit 0) #+mkcl (mk-ext:quit :exit-code 0)))
  (operate 'program-op 'hello-no-uiop :force t)
  (DBG :run (output-file 'program-op 'hello-no-uiop))
  (assert-equal
   (run-program `(,(native-namestring (output-file 'program-op 'hello-no-uiop)))
                :output :lines :error-output t)
   '("Look ma, no UIOP!" "But TEST-PACKAGE!")))

143
;;; TODO: include a regular system dependency and a prebuilt-system in the executable.