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.