script-support.lisp 17.4 KB
Newer Older
1
2
3
4
5
6
7
8
;;;;; Minimal life-support for testing ASDF from a blank Lisp image.
#|
Some constraints:
* We cannot rely on any test library that could be loaded by ASDF.
 And we cannot even rely on ASDF being present until we load it.
 But we *can* rely on ASDF being present *after* we load it.
* evaluating this file MUST NOT print anything,
 because we use it in the forward-ref test to check that nothing is printed.
9
10
* We make sure that none of our symbols clash with asdf/driver or asdf,
 so we may use-package them during testing.
11
12
|#

13
14
15
(defpackage :asdf-test
  (:use :common-lisp)
  (:export
16
   #:asym #:acall
17
   #:*test-directory* #:*asdf-directory*
18
19
   #:load-asdf #:maybe-compile-asdf
   #:load-asdf-lisp #:compile-asdf #:load-asdf-fasl
20
   #:compile-load-asdf #:load-asdf-system #:clean-load-asdf-system
21
22
23
   #:register-directory #:load-test-system
   #:with-test #:test-asdf #:debug-asdf
   #:assert-compare
24
   #:assert-equal
25
   #:leave-test #:def-test-system
26
   #:action-name #:in-plan-p
27
   #:test-source #:test-fasl #:resolve-output #:output-location
28
   #:quietly))
29

30
(in-package :asdf-test)
31

32
33
34
35
36
37
(declaim (optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3)
		   #+(or cmu scl) (c::brevity 2)))
(proclaim '(optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3)
		     #+(or cmu scl) (c::brevity 2)))

(defvar *trace-symbols*
38
  `(;; If you want to trace some stuff while debugging ASDF,
39
40
    ;; here's a nice place to say what.
    ;; These string designators will be interned in ASDF after it is loaded.
41
42
    
    ;;#+ecl ,@'( :perform :input-files :output-files :compile-file* :compile-file-pathname* :load*)
43
44
45
    ))

(defvar *debug-asdf* nil)
46
(defvar *quit-when-done* t)
47

48
49
50
(defun verbose (&optional (verbose t) (print verbose))
  (setf *load-verbose* verbose *compile-verbose* verbose)
  (setf *load-print* print *compile-print* print))
51
52
53

(verbose nil)

54
55
;;; Minimal compatibility layer
(eval-when (:compile-toplevel :load-toplevel :execute)
56
57
58
59
60
  #+allegro
  (setf excl:*warn-on-nested-reader-conditionals* nil
        excl::*autoload-package-name-alist*
        (remove "asdf" excl::*autoload-package-name-alist*
                :test 'equalp :key 'car)) ; We need that BEFORE any mention of package ASDF.
61
  #+cmucl (setf ext:*gc-verbose* nil)
62
63
64
65
  #+gcl
  (when (or (< system::*gcl-major-version* 2)
            (and (= system::*gcl-major-version* 2)
                 (< system::*gcl-minor-version* 7)))
66
67
    (shadowing-import 'system:*load-pathname* :asdf-test))
  #+lispworks
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
68
  (setf system:*stack-overflow-behaviour* :warn))
69
70
71
72
73

#+(or gcl genera)
(unless (fboundp 'ensure-directories-exist)
  (defun ensure-directories-exist (path)
    #+genera (fs:create-directories-recursively (pathname path))
74
75
    #+gcl (lisp:system (format nil "mkdir -p ~S"
                               (namestring (make-pathname :name nil :type nil :defaults path))))))
76
77
78

;;; Survival utilities
(defun asym (name)
79
80
81
82
  (let ((asdf (find-package :asdf)))
    (unless asdf (error "Can't find package ASDF"))
    (or (find-symbol (string name) asdf)
        (error "Can't find symbol ~A in ASDF" name))))
83
84
85
(defun acall (name &rest args)
  (apply (asym name) args))

86
(defun finish-outputs* ()
87
88
89
  (loop :for s :in (list *standard-output* *error-output* *trace-output* *debug-io*)
        :do (finish-output s)))
(defun redirect-outputs ()
90
  (finish-outputs*)
91
92
  (setf *error-output* *standard-output*
        *trace-output* *standard-output*))
93

94
(redirect-outputs) ;; Put everything on standard output, for the sake of scripts
95

96
97
98
99
;;; First, some pathname madness.
;; We can't use goodies from asdf/pathnames because ASDF isn't loaded yet.
;; We still want to work despite and host/device funkiness,
;; so we do it the hard way.
100
(defparameter *test-directory*
101
  (truename
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
   (make-pathname :name nil :type nil :version nil
                  :defaults (or *load-pathname* *compile-file-pathname*))))
(defun make-sub-pathname (&rest keys &key defaults &allow-other-keys)
  (merge-pathnames (apply 'make-pathname keys) defaults))
(defun relative-dir (&rest dir) #-gcl (cons ':relative dir) #+gcl dir)
(defun back-dir () #-gcl :back #+gcl :parent)
(defparameter *asdf-directory*
  (truename (make-sub-pathname :directory (relative-dir (back-dir)) :defaults *test-directory*)))
(defparameter *build-directory*
  (make-sub-pathname :directory (relative-dir "build") :defaults *asdf-directory*))
(defparameter *implementation*
  (or #+allegro
      (ecase excl:*current-case-mode*
        (:case-sensitive-lower :mlisp)
        (:case-insensitive-upper :alisp))
      #+armedbear :abcl
      #+clisp :clisp
      #+clozure :ccl
      #+cmu :cmucl
      #+corman :cormanlisp
      #+digitool :mcl
123
      #+ecl (or #+ecl-bytecmp :ecl_bytecodes :ecl)
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
      #+gcl :gcl
      #+lispworks :lispworks
      #+mkcl :mkcl
      #+sbcl :sbcl
      #+scl :scl
      #+xcl :xcl))
(defparameter *early-fasl-directory*
  (make-sub-pathname :directory (relative-dir "fasls" (string-downcase *implementation*))
                     :defaults *build-directory*))

(defun asdf-name (&optional tag)
  (format nil "asdf~@[-~A~]" tag))
(defun asdf-lisp (&optional tag)
  (make-pathname :name (asdf-name tag) :type "lisp" :defaults *build-directory*))
(defun debug-lisp ()
  (make-sub-pathname :directory (relative-dir "contrib") :name "debug" :type "lisp" :defaults *asdf-directory*))
(defun early-compile-file-pathname (file)
141
  (compile-file-pathname
142
143
144
   (make-pathname :name (pathname-name file) :type "lisp" :defaults *early-fasl-directory*)))
(defun asdf-fasl (&optional tag)
  (early-compile-file-pathname (asdf-lisp tag)))
145

146
147
148

;;; Test helper functions

149
(load (debug-lisp))
150
(verbose t nil)
151

152
153
154
155
156
157
158
159
160
161
162
163
(defmacro assert-compare (expr)
  (destructuring-bind (op x y) expr
    `(assert-compare-helper ',op ',x ',y ,x ,y)))

(defun assert-compare-helper (op qx qy x y)
  (unless (funcall op x y)
    (error "These two expressions fail comparison with ~S:~%~
            ~S evaluates to ~S~% ~S evaluates to ~S~%"
            op qx x qy y)))

(defmacro assert-equal (x y)
  `(assert-compare (equal ,x ,y)))
164

165
166
(defun touch-file (file &key (offset 0) timestamp)
  (let ((timestamp (or timestamp (+ offset (get-universal-time)))))
167
    (multiple-value-bind (sec min hr day month year) (decode-universal-time timestamp #+gcl<2.7 -5)
168
      (acall :run-program
169
170
171
             `("touch" "-t" ,(format nil "~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D"
                                     year month day hr min sec)
                       ,(namestring file)))
172
      (assert-equal (file-write-date file) timestamp))))
173

174
175
176
177
(defun hash-table->alist (table)
  (loop :for key :being :the :hash-keys :of table :using (:hash-value value)
    :collect (cons key value)))

178
(defun exit-lisp (&optional (code 0)) ;; Simplified from asdf/image:quit
179
  (finish-outputs*)
180
181
182
183
184
185
186
187
188
189
190
191
  #+(or abcl xcl) (ext:quit :status code)
  #+allegro (excl:exit code :quiet t)
  #+clisp (ext:quit code)
  #+clozure (ccl:quit code)
  #+cormanlisp (win32:exitprocess code)
  #+(or cmu scl) (unix:unix-exit code)
  #+ecl (si:quit code)
  #+gcl (lisp:quit code)
  #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
  #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
  #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
  #+mkcl (mk-ext:quit :exit-code code)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
192
  #+sbcl #.(let ((exit (find-symbol "EXIT" :sb-ext))
193
		 (quit* (find-symbol "QUIT" :sb-ext)))
194
195
	     (cond
	       (exit `(,exit :code code :abort t))
196
	       (quit* `(,quit* :unix-status code :recklessly-p t))))
197
198
  #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
  (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code))
199
200


201
(defun leave-test (message return)
202
  (finish-outputs*)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
203
204
205
  (fresh-line *error-output*)
  (when message
    (format *error-output* message)
206
    (fresh-line *error-output*))
207
  (finish-outputs*)
208
  (throw :asdf-test-done return))
209

210
(defmacro with-test ((&optional) &body body)
211
  `(call-with-test (lambda () ,@body)))
212

213
(defun call-with-test (thunk)
Robert P. Goldman's avatar
   
Robert P. Goldman committed
214
215
216
  "Unless the environment variable DEBUG_ASDF_TEST
is bound, write a message and exit on an error.  If
*asdf-test-debug* is true, enter the debugger."
217
  (redirect-outputs)
218
219
220
221
  (let ((result
          (catch :asdf-test-done
            (handler-bind
                ((error (lambda (c)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
222
223
                          (ignore-errors
                           (format *error-output* "~&TEST ABORTED: ~A~&" c))
224
                          (finish-outputs*)
225
                          (cond
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
226
227
228
                            (*debug-asdf*
                             (format t "~&It's your baby, fix it!~%")
                             (break))
229
                            (t
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
230
231
232
                             (ignore-errors
                              (acall :print-condition-backtrace
                                     c :count 69 :stream *error-output*))
233
234
235
                             (leave-test "Script failed" 1))))))
              (funcall thunk)
              (leave-test "Script succeeded" 0)))))
236
    (when *quit-when-done*
237
      (exit-lisp result))))
238
239
240
241
242
243
244
245
246
247

;;; These are used by the upgrade tests

(defmacro quietly (&body body)
  `(call-quietly #'(lambda () ,@body)))

(defun call-quietly (thunk)
  (handler-bind (#+sbcl (sb-kernel:redefinition-warning #'muffle-warning))
    (funcall thunk)))

248
(defun load-asdf-lisp (&optional tag)
249
  (quietly (load (asdf-lisp tag) :verbose *load-verbose* :print *load-print*)))
250

251
252
(defun load-asdf-fasl (&optional tag)
  (quietly (load (asdf-fasl tag))))
253
254

(defun register-directory (dir)
255
  (pushnew dir (symbol-value (asym :*central-registry*))))
256

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
257
(defun load-asdf-system (&rest keys)
258
259
  (quietly
   (register-directory *asdf-directory*)
260
261
   (apply (asym :oos) (asym :load-op) :asdf keys)))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
262
(defun call-with-asdf-conditions (thunk &optional verbose)
263
  (declare (ignorable verbose))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
264
265
266
267
  (handler-bind (#+sbcl
                 ((or sb-c::simple-compiler-note sb-kernel:redefinition-warning)
                   #'muffle-warning)
                 #+(and ecl (not ecl-bytecmp))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
268
269
                 ((or c::compiler-note c::compiler-debug-note
                      c::compiler-warning) ;; ECL emits more serious warnings than it should.
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
                   #'muffle-warning)
                 #+mkcl
                 ((or compiler:compiler-note) #'muffle-warning)
                 #-(or cmu scl)
                 ;; style warnings shouldn't abort the compilation [2010/02/03:rpg]
                 (style-warning
                   #'(lambda (w)
                       ;; escalate style-warnings to warnings - we don't want them.
                       (when verbose
                         (warn "Can you please fix ASDF to not emit style-warnings? Got a ~S:~%~A"
                               (type-of w) w))
                       (muffle-warning w))))
    (funcall thunk)))

(defmacro with-asdf-conditions ((&optional verbose) &body body)
  `(call-with-asdf-conditions #'(lambda () ,@body) ,verbose))

287
288
289
290
291
292
(defun compile-asdf (&optional tag verbose)
  (let* ((alisp (asdf-lisp tag))
         (afasl (asdf-fasl tag))
         (tmp (make-pathname :name "asdf-tmp" :defaults afasl)))
    (ensure-directories-exist afasl)
    (multiple-value-bind (result warnings-p errors-p)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
293
        (compile-file alisp :output-file tmp #-gcl :verbose #-gcl verbose :print verbose)
294
295
296
297
298
299
300
301
302
303
304
305
306
307
      (flet ((bad (key)
               (when result (ignore-errors (delete-file result)))
               key)
             (good (key)
               (when (probe-file afasl) (delete-file afasl))
               (rename-file tmp afasl)
               key))
        (cond
          (errors-p (bad :errors))
          (warnings-p
           (or
            ;; ECL 11.1.1 has spurious warnings, same with XCL 0.0.0.291.
            ;; SCL has no warning but still raises the warningp flag since 2.20.15 (?)
            #+(or cmu ecl scl xcl) (good :expected-warnings)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
308
          (bad :unexpected-warnings)))
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
          (t (good :success)))))))

(defun maybe-compile-asdf (&optional tag)
  (let ((alisp (asdf-lisp tag))
        (afasl (asdf-fasl tag)))
    (cond
      ((not (probe-file alisp))
       :not-found)
      ((and (probe-file afasl)
            (> (file-write-date afasl) (file-write-date alisp))
            (ignore-errors (load-asdf-fasl tag)))
       :previously-compiled)
      (t
       (load-asdf-lisp tag)
       (compile-asdf tag)))))

(defun compile-asdf-script ()
  (with-test ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
327
    (ecase (with-asdf-conditions () (maybe-compile-asdf))
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
      (:not-found
       (leave-test "Testsuite failed: unable to find ASDF source" 3))
      (:previously-compiled
       (leave-test "Reusing previously-compiled ASDF" 0))
      (:errors
       (leave-test "Testsuite failed: ASDF compiled with ERRORS" 2))
      (:unexpected-warnings
       (leave-test "Testsuite failed: ASDF compiled with unexpected warnings" 1))
      (:expected-warnings
       (leave-test "ASDF compiled with warnings, ignored for your implementation" 0))
      (:success
       (leave-test "ASDF compiled cleanly" 0)))))

(defun compile-load-asdf (&optional tag)
  ;; emulate the way asdf upgrades itself: load source, compile, load fasl.
  (load-asdf-lisp tag)
  (ecase (compile-asdf tag)
    ((:errors :unexpected-warnings) (leave-test "failed to compile ASDF" 1))
    ((:expected-warnings :success)
     (load-asdf-fasl tag))))

;;; Now, functions to compile and load ASDF.

(defun load-test-system (x &key verbose)
  (let ((*load-print* verbose)
        (*load-verbose* verbose))
    (register-directory *test-directory*)
    (acall :oos (asym :load-op) x :verbose verbose)))
356

357
358
(defun get-asdf-version ()
  (when (find-package :asdf)
359
360
361
362
363
364
365
    (let ((ver (symbol-value (or (find-symbol (string :*asdf-version*) :asdf)
                                 (find-symbol (string :*asdf-revision*) :asdf)))))
      (typecase ver
        (string ver)
        (cons (format nil "~{~D~^.~}" ver))
        (null "1.0")))))

366

367
(defun test-upgrade (old-method new-method tag) ;; called by run-test
368
  (with-test ()
369
370
    (when old-method
      (cond
371
        ((string-equal tag "REQUIRE")
372
         (format t "Requiring some previous ASDF ~A~%" tag)
373
         (ignore-errors (funcall 'require "asdf"))
374
375
376
         (if (member "ASDF" *modules* :test 'equalp)
             (format t "Your Lisp implementation provided ASDF ~A~%" (get-asdf-version))
             (leave-test "Your Lisp implementation does not provide ASDF. Skipping test.~%" 0)))
377
378
379
380
381
        (t
         (format t "Loading old asdf ~A via ~A~%" tag old-method)
         (funcall old-method tag))))
    (format t "Now loading new asdf via method ~A~%" new-method)
    (funcall new-method)
382
    (format t "Testing it~%")
383
    (register-directory *test-directory*)
384
385
386
    (load-test-system :test-module-depend)
    (assert (eval (intern (symbol-name '#:*file1*) :test-package)))
    (assert (eval (intern (symbol-name '#:*file3*) :test-package)))))
387

388
389
390
391
392
393
394
395
396
397
398
399
400
(defun output-location (&rest sublocation)
  (list* *asdf-directory* "build/fasls" :implementation sublocation))
(defun resolve-output (&rest sublocation)
  (acall :resolve-location (apply 'output-location sublocation)))

(defun test-source (file)
  (acall :subpathname *test-directory* file))
(defun test-output-dir ()
  (resolve-output "asdf" "test"))
(defun test-output (file)
  (acall :subpathname (test-output-dir) file))
(defun test-fasl (file)
  (acall :compile-file-pathname* (test-source file)))
401
402
403
404
405
406
407
408

(defun clean-asdf-system ()
  (let ((fasl (resolve-output "asdf" "build" "asdf.fasl")))
    (when (DBG :clean fasl (probe-file fasl)) (delete-file fasl))))

(defun load-asdf-lisp-clean ()
  (load-asdf-lisp)
  (clean-asdf-system))
409

410
411
(defun configure-asdf ()
  (setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST")))
412
  (untrace)
413
414
415
416
417
  (eval `(trace ,@(loop :for s :in *trace-symbols* :collect (asym s))))
  (acall :initialize-source-registry
         `(:source-registry :ignore-inherited-configuration))
  (acall :initialize-output-translations
         `(:output-translations
418
419
           ((,*asdf-directory* :**/ :*.*.*) ,(output-location "asdf"))
           (t ,(output-location "root"))
420
421
422
423
424
425
426
427
           :ignore-inherited-configuration))
  (set (asym :*central-registry*) `(,*test-directory*))
  (set (asym :*verbose-out*) *standard-output*)
  (set (asym :*asdf-verbose*) t))

(defun load-asdf (&optional tag)
  (load-asdf-fasl tag)
  (use-package :asdf :asdf-test)
428
  (use-package :asdf/driver :asdf-test)
429
430
  (configure-asdf)
  (setf *package* (find-package :asdf-test)))
431

432
433
(defun debug-asdf ()
  (setf *debug-asdf* t)
434
  (setf *quit-when-done* nil)
435
436
  (setf *package* (find-package :asdf-test)))

437
438
(defun just-load-asdf-fasl () (load-asdf-fasl))

439
;; Actual scripts rely on this function:
440
(defun common-lisp-user::load-asdf () (load-asdf))
441

442
443
444
445
446
447
(setf *package* (find-package :asdf-test))

(defmacro def-test-system (name &rest rest)
  `(apply (asym :register-system-definition) ',name :pathname ,*test-directory*
          :source-file nil ',rest))

448
449
450
(defun in-plan-p (plan x) (member x plan :key (asym :action-path) :test 'equal))


451
452
453
454
;; These are shorthands for interactive debugging of test scripts:
(!a
 common-lisp-user::debug-asdf debug-asdf
 da debug-asdf common-lisp-user::da debug-asdf
455
456
457
 la load-asdf common-lisp-user::la load-asdf
 ll load-asdf-lisp
 v verbose)
458

459
460
461
462
#| For the record, the following form is sometimes useful to insert in
 asdf/plan:compute-action-stamp to find out what's happening.
 It depends on the DBG macro in contrib/debug.lisp,
 that you should load in your asdf/plan by inserting an (asdf-debug) form in it.
463

464
465
466
467
 (let ((action-path (action-path (cons o c)))) (DBG :cas action-path just-done plan stamp-lookup out-files in-files out-op op-time dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in up-to-date-p done-stamp (operation-done-p o c)
;;; blah
))
|#