test-program.script 7.84 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 127
  #+mkcl (assert (probe-file* (asdf/bundle::system-module-pathname "uiop")))
  (assert (probe-file* (asdf/bundle::system-module-pathname "asdf")))
  #+ecl (assert (probe-file* (asdf/bundle::system-module-pathname "cmp")))
128 129 130 131 132 133 134
  (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))
135 136
      (format t "~:[But no TEST-PACKAGE :-(~;And TEST-PACKAGE~]!~%" (find-package :test-package))
      (format t "~:[And no ASDF~;But ASDF :-( ~]!~%" (find-package :asdf))
137 138 139 140 141 142
      #+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)
143 144 145 146 147
   '("Look ma, no UIOP!" "And TEST-PACKAGE!" "And no ASDF!"))

  (DBG "Now create an program with explicit ASDF dependency, without registered ASDF (use implementation-provided prebuilt)")
  (assert-pathname-equal
   (truename (pathname-directory-pathname (output-file 'lib-op (asdf/bundle::linkable-system "asdf"))))
148
   (truename (subpathname (lisp-implementation-directory) #+mkcl "contrib/" #-mkcl nil)))
149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177
  (def-test-system hello-asdf
    :class program-system
    :depends-on ("asdf")
    :components ((:file "file1"))
    :epilogue-code
    (progn
      (format t "~:[~Oops, no ASDF~;Look ma, ASDF~]!~%" (find-package :asdf))
      (format t "~:[But no TEST-PACKAGE :-( ~;And TEST-PACKAGE~]!~%" (find-package :test-package))
      (uiop:quit 0)))
  (operate 'program-op 'hello-asdf :force t)
  (DBG :run (output-file 'program-op 'hello-asdf))
  (assert-equal
   (run-program `(,(native-namestring (output-file 'program-op 'hello-asdf)))
                :output :lines :error-output t)
   '("Look ma, ASDF!" "And TEST-PACKAGE!"))

  (DBG "Now create an program with explicit ASDF dependency")
  (register-directory *asdf-directory*)
  (with-asdf-cache (:override t)
    (load-asd (subpathname *asdf-directory* "asdf.asd")) ;; force re-loading ASDF, from source
    (assert-pathname-equal
     (truename (pathname-directory-pathname (output-file 'lib-op (asdf/bundle::linkable-system "asdf"))))
     (truename (resolve-output "asdf/")))
    (operate 'program-op 'hello-asdf :force t)
    (DBG :run (output-file 'program-op 'hello-asdf))
    (assert-equal
     (run-program `(,(native-namestring (output-file 'program-op 'hello-asdf)))
                  :output :lines :error-output t)
     '("Look ma, ASDF!" "And TEST-PACKAGE!"))))
178

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