test-program.script 8.11 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 ext/ or from the user environment.
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
   '("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)")
150
151
152
153
  (clear-system :asdf)
  (setf *central-registry* nil)
  (initialize-source-registry `(:source-registry :ignore-inherited-configuration))
  (DBG :foo (system-source-file :asdf))
154
155
  (assert-pathname-equal
   (truename (pathname-directory-pathname (output-file 'lib-op (asdf/bundle::linkable-system "asdf"))))
156
   (truename (subpathname (lisp-implementation-directory) #+mkcl "contrib/" #-mkcl nil)))
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
  (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*)
175
176
  (load-asd (subpathname *asdf-directory* "asdf.asd")) ;; force re-loading ASDF, from source
  (with-asdf-session (:override t)
177
178
179
180
181
182
183
184
185
    (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!"))))
186

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