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

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

9 10 11 12 13 14 15 16 17 18 19 20 21 22
#+(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)))))))

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

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

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

55 56 57 58 59 60 61
(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)
62
  #+cmucl
63 64
  (unless (probe-file* img)
    (leave-test "CMUCL seemingly can't find the 32-bit compiler and libraries required to dump images. Aborting test." 0))
65
  (assert (probe-file* img) () "Can't find image file ~S" img)
66

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

80
  (DBG "- now, use this executable image with arguments")
81 82
  #-(or lispworks scl) ;; These can't be passed arguments the normal way
  (assert-equal
83
   (lisp-invocation:invoke-lisp
84
    :implementation-type (lisp-invocation/allegro-variants:current-lisp-variant)
85 86
    :image-path (native-namestring img)
    :cross-compile nil
87
    :console t
88 89 90
    :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))
91 92 93 94 95
   '("hello, world"
     "You passed 3 arguments:"
     "  \"a\""
     "  \"b c\""
     "  \"d\"")))
96

97 98 99
(progn
  (DBG "test program-op")
  (unless (or #+(or clisp clozure (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl) t
100
              #+cmucl nil ;; uncomment if you have 32-bit gcc support - or can autodetect
101 102 103 104 105
              #+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))
106

107 108 109 110 111 112
  (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)
113

114
  (DBG "- use that standalone program")
115 116
  (assert-equal (run-program `(,(native-namestring exe)) :output :lines :error-output t)
                '("hello, world"))
117

118
  (DBG "- use that standalone program with arguments")
119 120 121 122 123 124
  (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\"")))
125

126 127 128
#+(or ecl mkcl)
(progn
  (DBG "Now create an program without UIOP")
129 130 131
  #+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")))
132 133 134 135 136 137 138
  (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))
139 140
      (format t "~:[But no TEST-PACKAGE :-(~;And TEST-PACKAGE~]!~%" (find-package :test-package))
      (format t "~:[And no ASDF~;But ASDF :-( ~]!~%" (find-package :asdf))
141 142 143 144 145 146
      #+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)
147 148 149 150 151
   '("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"))))
152
   (truename (subpathname (lisp-implementation-directory) #+mkcl "contrib/" #-mkcl nil)))
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 178 179 180 181
  (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!"))))
182

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