test-program.script 7.79 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
  (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))
134
135
      (format t "~:[But no TEST-PACKAGE :-(~;And TEST-PACKAGE~]!~%" (find-package :test-package))
      (format t "~:[And no ASDF~;But ASDF :-( ~]!~%" (find-package :asdf))
136
137
138
139
140
141
      #+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)
142
143
144
145
146
147
148
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
   '("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)")
  (trace c::builder) ;; component-depends-on input-files output-files
  (assert-pathname-equal
   (truename (pathname-directory-pathname (output-file 'lib-op (asdf/bundle::linkable-system "asdf"))))
   (truename (lisp-implementation-directory)))
  (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.