script-support.lisp 29.3 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
* We make sure that none of our symbols clash with uiop or asdf,
10
 so we may use-package them during testing.
11
12
|#

13
14
15
(defpackage :asdf-test
  (:use :common-lisp)
  (:export
16
   #:asym #:acall #:asymval
17
   #:*test-directory* #:*asdf-directory* #:*build-directory* #:*implementation*
18
   #:deftest #:is #:signals #:errors #:with-expected-failure
19
   #:assert-compare #:assert-equal #:assert-pathname-equal #:assert-pathnames-equal
20
   #:hash-table->alist
21
22
   #:load-asdf #:maybe-compile-asdf
   #:load-asdf-lisp #:compile-asdf #:load-asdf-fasl
23
24
   #:compile-load-asdf #:compile-load-asdf-upgrade
   #:load-asdf-system #:clean-load-asdf-system
25
26
   #:register-directory #:load-test-system
   #:with-test #:test-asdf #:debug-asdf
27
   #:run-test-script #:interactive-test #:test-load-systems
28
   #:verbose #:exit-lisp
29
   #:assert-compare
30
   #:assert-equal
31
   #:leave-test #:def-test-system
32
   #:action-name #:in-plan-p
33
   #:test-source #:test-fasl #:resolve-output #:output-location
34
   #:quietly #:join-namestrings))
35

36
(in-package :asdf-test)
37

38
39
#+(and ecl (not ecl-bytecmp)) (require :cmp)

40
(declaim (optimize (speed 2) (safety #-gcl 3 #+gcl 0) #-(or allegro gcl genera) (debug 3)
41
                   #+(or cmu scl) (c::brevity 2)))
42
(proclaim '(optimize (speed #-gcl 2 #+gcl 1) (safety #-gcl 3 #+gcl 0) #-(or allegro gcl genera) (debug 3)
43
                     #+(or cmu scl) (c::brevity 2) #+(or cmu scl) (ext:inhibit-warnings 3)))
44

45
(defparameter *trace-symbols*
46
  `(;; If you want to trace some stuff while debugging ASDF,
47
48
    ;; here's a nice place to say what.
    ;; These string designators will be interned in ASDF after it is loaded.
49
    ;;#+ecl ,@'( :perform :input-files :output-files :compile-file* :compile-file-pathname* :load*)
50
51
52
    ))

(defvar *debug-asdf* nil)
53
(defvar *quit-when-done* t)
54

55
56
57
(defun verbose (&optional (verbose t) (print verbose))
  (setf *load-verbose* verbose *compile-verbose* verbose)
  (setf *load-print* print *compile-print* print))
58
59
60

(verbose nil)

61
62
;;; Minimal compatibility layer
(eval-when (:compile-toplevel :load-toplevel :execute)
63
64
65
66
67
  #+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.
68
  #+cmucl (setf ext:*gc-verbose* nil)
69
  #+gcl
70
  (si::use-fast-links nil)
71
  #+lispworks
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
72
  (setf system:*stack-overflow-behaviour* :warn))
73

74
#+genera
75
76
(unless (fboundp 'ensure-directories-exist)
  (defun ensure-directories-exist (path)
77
    #+genera (fs:create-directories-recursively (pathname path))))
78
79

;;; Survival utilities
80
(defun asym (name &optional package errorp)
81
82
83
84
85
86
  (let* ((pname (or package :asdf))
         (package (find-package pname)))
    (if package
        (or (find-symbol (string name) package)
            (when errorp (error "Can't find symbol ~A in ~A" name pname)))
        (when errorp (error "Can't find package ~A" pname)))))
87
(defun acall (name &rest args)
88
89
90
  (apply (apply 'asym (if (consp name) name (list name))) args))
(defun asymval (name &optional package)
  (symbol-value (asym name package)))
91
(defsetf asymval (name &optional package) (new-value)
92
93
94
95
96
  (let ((sym (gensym "SYM")))
    `(let ((,sym (asym ,name ,package)))
       (if ,sym
           (setf (symbol-value ,sym) ,new-value)
           (error "NIHIL EX NIHILO")))))
97

98
(defun finish-outputs* ()
99
100
101
  (loop :for s :in (list *standard-output* *error-output* *trace-output* *debug-io*)
        :do (finish-output s)))
(defun redirect-outputs ()
102
  (finish-outputs*)
103
104
  (setf *error-output* *standard-output*
        *trace-output* *standard-output*))
105

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

108
109
110
111
112
113
114
115
;;; Poor man's test suite, lacking stefil.
(defmacro deftest (name formals &body body)
  `(defun ,name ,formals ,@body))
(defmacro is (x)
  `(progn
     (format *error-output* "~&Checking whether ~S~%" ',x)
     (finish-output *error-output*)
     (assert ,x)))
116
(defmacro signals (condition sexp &aux (x (gensym)))
117
118
119
120
121
  `(progn
     (format *error-output* "~&Checking whether ~S signals ~S~%" ',sexp ',condition)
     (finish-output *error-output*)
     (handler-case
         ,sexp
122
123
124
125
126
127
128
129
130
       (,condition (,x)
         (format *error-output* "~&Received signal ~S~%" ,x)
         (finish-output *error-output*)
         t)
       (:no-error (&rest ,x)
         (error "Expression ~S fails to raise condition ~S, instead returning~{ ~S~}"
                ',sexp ',condition ,x))
       (t (,x)
         (error "Expression ~S raises signal ~S, not ~S" ',sexp ,x ',condition)))))
131
132
133
134
135
(defmacro errors (condition sexp)
  `(progn
     (format *error-output* "~&Checking whether ~S signals error ~S~%" ',sexp ',condition)
     (finish-output *error-output*)
     (assert-equal ',condition (type-of (nth-value 1 (ignore-errors ,sexp))))))
136
137
138
139
140
141
142
143
144
145
(defmacro with-expected-failure ((&optional condition) &body body)
  `(call-with-expected-failure ,condition (lambda () ,@body)))
(defun call-with-expected-failure (condition thunk)
  (if condition
      (handler-case (funcall thunk)
        (:no-error (&rest x) (declare (ignore x)) (error "Unexpected success: ~A" condition))
        (t (x) (declare (ignore x)) t))
      (funcall thunk)))


146

147
;;; Helpful for debugging
148
149
150
151
152
153
154
155
156
157
158
159
160
(defun pathname-components (p)
  (when p
    (let ((p (pathname p)))
      (list :host (pathname-host p)
            :device (pathname-device p)
            :directory (pathname-directory p)
            :name (pathname-name p)
            :type (pathname-type p)
            :version (pathname-version p)))))

(defun assert-pathname-equal-helper (qx x qy y)
  (cond
    ((equal x y)
161
     (format t "~S and~% ~S both evaluate to same path:~%  ~S~%" qx qy x))
162
163
164
    #+mkcl
    ((acall :pathname-equal x y)
     (format t "~S and ~S evaluate to functionaly equivalent paths, respectively:~%  ~S~%and~%  ~S~%" qx qy x y))
165
    ((acall :pathname-equal x y)
166
     (warn "These two expressions yield pathname-equal yet not equal path~%~
167
168
169
170
        the first expression ~S yields this:~%  ~S~%  ~S~%
        the other expression ~S yields that:~%  ~S~%  ~S~%"
        qx x (pathname-components x)
        qy y (pathname-components y)))
171
    ;; accept equalp namestrings, to account for case-independent filesystems
172
    ((equalp (and x (namestring x)) (and y (namestring y)))
173
174
175
176
177
     (warn "These two expressions yield pathnames that have equalp namestrings yet are not pathname-equal~%~
        the first expression ~S yields this:~%  ~S~%  ~S~%
        the other expression ~S yields that:~%  ~S~%  ~S~%"
        qx x (pathname-components x)
        qy y (pathname-components y)))
178
    (t
179
     (error "These two expressions yield paths that are not equal in any way:~%~
180
181
182
183
        the first expression ~S yields this:~%  ~S~%  ~S~%
        the other expression ~S yields that:~%  ~S~%  ~S~%"
        qx x (pathname-components x)
        qy y (pathname-components y)))))
184
185
(defmacro assert-pathname-equal (x y)
  `(assert-pathname-equal-helper ',x ,x ',y ,y))
186
(defun assert-length-equal-helper (qx x qy y)
187
  (unless (= (length x) (length y))
188
    (error "These two expressions yield sequences of unequal length~%
189
190
        The first, ~S, has value ~S of length ~S~%
        The other, ~S, has value ~S of length ~S~%"
191
           qx x (length x) qy y (length y))))
192
193
194
195
196
197
198
199
200
201
202
203
(defun assert-pathnames-equal-helper (qx x qy y)
  (assert-length-equal-helper qx x qy y)
  (loop :for n :from 0
        :for qpx = `(nth ,n ,qx)
        :for qpy = `(nth ,n ,qy)
        :for px :in x
        :for py :in y :do
        (assert-pathname-equal-helper qpx px qpy py)))
(defmacro assert-pathnames-equal (x y)
  `(assert-pathnames-equal-helper ',x ,x ',y ,y))

;; More pathname madness.
204
205
206
;; 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.
207
(defparameter *test-directory*
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
  ;; the following is annoyingly named "test-getenv" to avoid symbol clash
  ;; later when we use UIOP.
  (flet ((test-getenv (x)
           (declare (ignorable x))
           #+(or abcl clasp clisp ecl xcl) (ext:getenv x)
           #+allegro (sys:getenv x)
           #+clozure (ccl:getenv x)
           #+cmucl (unix:unix-getenv x)
           #+scl (cdr (assoc x ext:*environment-list* :test #'string=))
           #+cormanlisp
           (let* ((buffer (ct:malloc 1))
                  (cname (ct:lisp-string-to-c-string x))
                  (needed-size (win:getenvironmentvariable cname buffer 0))
                  (buffer1 (ct:malloc (1+ needed-size))))
             (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
                        nil
                      (ct:c-string-to-lisp-string buffer1))
               (ct:free buffer)
               (ct:free buffer1)))
           #+gcl (system:getenv x)
           #+genera nil
           #+lispworks (lispworks:environment-variable x)
           #+mcl (ccl:with-cstrs ((name x))
                                 (let ((value (_getenv name)))
                                   (unless (ccl:%null-ptr-p value)
                                     (ccl:%get-cstring value))))
           #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x)
           #+sbcl (sb-ext:posix-getenv x)
           #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
           (error "~S is not supported on your implementation" 'getenv)))
    (or (test-getenv "ASDF_TEST_DIRECTORY")
        (truename
         (make-pathname :name nil :type nil :version nil
                        :defaults (or *load-pathname* *compile-file-pathname* *default-pathname-defaults*))))))

243
244
245
(defun make-sub-pathname (&rest keys &key defaults &allow-other-keys)
  (merge-pathnames (apply 'make-pathname keys) defaults))
(defparameter *asdf-directory*
246
  (truename (make-sub-pathname :directory '(:relative :back) :defaults *test-directory*)))
247
(defparameter *uiop-directory*
248
  (truename (make-sub-pathname :directory '(:relative "uiop") :defaults *asdf-directory*)))
249
(defparameter *build-directory*
250
  (make-sub-pathname :directory '(:relative "build") :defaults *asdf-directory*))
251
252
253
254
255
256
(defparameter *implementation*
  (or #+allegro
      (ecase excl:*current-case-mode*
        (:case-sensitive-lower :mlisp)
        (:case-insensitive-upper :alisp))
      #+armedbear :abcl
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
257
      #+(or clasp ecl) (or #+ecl-bytecmp :ecl_bytecodes :ecl)
258
259
260
261
262
263
264
265
266
267
268
269
      #+clisp :clisp
      #+clozure :ccl
      #+cmu :cmucl
      #+corman :cormanlisp
      #+digitool :mcl
      #+gcl :gcl
      #+lispworks :lispworks
      #+mkcl :mkcl
      #+sbcl :sbcl
      #+scl :scl
      #+xcl :xcl))
(defparameter *early-fasl-directory*
270
  (make-sub-pathname :directory `(:relative "fasls" ,(string-downcase *implementation*))
271
272
273
274
275
276
277
                     :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 ()
278
  (make-sub-pathname :directory '(:relative "contrib") :name "debug" :type "lisp" :defaults *uiop-directory*))
279
(defun early-compile-file-pathname (file)
280
  (compile-file-pathname
281
282
283
   (make-pathname :name (pathname-name file) :type "lisp" :defaults *early-fasl-directory*)))
(defun asdf-fasl (&optional tag)
  (early-compile-file-pathname (asdf-lisp tag)))
284

285
286
;;; Test helper functions

287
(load (debug-lisp))
288
(verbose t nil)
289

290
291
292
293
294
295
(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)
296
    (error "These two expressions fail comparison with ~S:~% ~
297
298
299
300
301
            ~S evaluates to ~S~% ~S evaluates to ~S~%"
            op qx x qy y)))

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

303
304
305
306
307
308
309
310
(defun set-equality (s1 s2 &key (test 'eql))
  (and (= (length s1) (length s2))
       (every #'(lambda (x)
                  (some #'(lambda (y)
                            (funcall test x y))
                        s2))
              s1)))

311
(defun touch-file (file &key offset timestamp in-filesystem)
312
313
  (let* ((base (or timestamp (get-universal-time)))
         (stamp (if offset (+ base offset) base)))
314
    (if (and (asymval :*asdf-cache*) (not in-filesystem))
315
316
        (acall :register-file-stamp file stamp)
        (multiple-value-bind (sec min hr day month year)
317
            (decode-universal-time stamp)
318
319
          (unless in-filesystem
            (error "Y U NO use stamp cache?"))
320
          (acall :run-program
321
322
                 `("touch" "-t" ,(format nil "~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D"
                                         year month day hr min sec)
323
                           ,(acall :native-namestring file)))
324
325
          (assert-equal (file-write-date file) stamp)))))
(defun mark-file-deleted (file)
326
  (unless (asymval :*asdf-cache*) (error "Y U NO use asdf cache?"))
327
  (acall :register-file-stamp (acall :normalize-namestring file) nil))
328

329
330
331
332
(defun hash-table->alist (table)
  (loop :for key :being :the :hash-keys :of table :using (:hash-value value)
    :collect (cons key value)))

333
(defun exit-lisp (&optional (code 0)) ;; Simplified from asdf/image:quit
334
  (finish-outputs*)
335
336
  #+(or abcl xcl) (ext:quit :status code)
  #+allegro (excl:exit code :quiet t)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
337
  #+(or clasp ecl) (si:quit code)
338
339
340
341
  #+clisp (ext:quit code)
  #+clozure (ccl:quit code)
  #+cormanlisp (win32:exitprocess code)
  #+(or cmu scl) (unix:unix-exit code)
342
  #+gcl (system:quit code)
343
344
345
346
  #+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
347
  #+sbcl #.(let ((exit (find-symbol "EXIT" :sb-ext))
348
349
350
351
                 (quit* (find-symbol "QUIT" :sb-ext)))
             (cond
               (exit `(,exit :code code :abort t))
               (quit* `(,quit* :unix-status code :recklessly-p t))))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
352
  #-(or abcl allegro clasp clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
353
  (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code))
354
355


356
(defun leave-test (message return)
357
358
  "Print MESSAGE and throw RETURN, which should be a POSIX error
code (an integer, 0 for success), up as exit code."
359
  (finish-outputs*)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
360
361
362
  (fresh-line *error-output*)
  (when message
    (format *error-output* message)
363
    (fresh-line *error-output*))
364
  (finish-outputs*)
365
  (throw :asdf-test-done return))
366

367
(defmacro with-test ((&optional) &body body)
368
  `(call-with-test (lambda () ,@body)))
369

370
(defun call-with-test (thunk)
Robert P. Goldman's avatar
 
Robert P. Goldman committed
371
372
373
  "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."
374
  (redirect-outputs)
375
376
377
378
  (let ((result
          (catch :asdf-test-done
            (handler-bind
                ((error (lambda (c)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
379
380
                          (ignore-errors
                           (format *error-output* "~&TEST ABORTED: ~A~&" c))
381
                          (finish-outputs*)
382
                          (cond
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
383
384
385
                            (*debug-asdf*
                             (format t "~&It's your baby, fix it!~%")
                             (break))
386
                            (t
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
387
                             (ignore-errors
388
                              (acall :print-condition-backtrace
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
389
                                     c :count 69 :stream *error-output*))
390
                             (leave-test "Script failed" 1))))))
391
              (funcall (or (asym :call-with-asdf-cache) 'funcall) thunk)
392
              (leave-test "Script succeeded" 0)))))
393
    (when *quit-when-done*
394
      (exit-lisp result))))
395
396
397
398
399
400
401

;;; These are used by the upgrade tests

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

(defun call-quietly (thunk)
402
  #-allegro
403
  (handler-bind (#+sbcl (sb-kernel:redefinition-warning #'muffle-warning))
404
405
406
    (funcall thunk))
  #+allegro
  (excl:without-redefinition-warnings
407
   (funcall thunk)))
408

409
410
411
412
(defun interactive-test (&optional files)
  (verbose t nil)
  (loop :for file :in files :do
    (load (string-downcase file)))
413
  (setf *package* (some 'find-package '(:asdf :uiop :asdf/utility :asdf/package :asdf-test)))
414
415
  (load "contrib/debug.lisp"))

416
417
418
419
420
421
(defun run-test-script (file)
  (with-test ()
    (let ((name (string file)))
      (format t "Running ~A with ~A~%" name (acall :implementation-identifier))
      (load name))))

422
(defun load-asdf-lisp (&optional tag)
423
  (quietly (load (asdf-lisp tag) :verbose *load-verbose* :print *load-print*)))
424

425
426
(defun load-asdf-fasl (&optional tag)
  (quietly (load (asdf-fasl tag))))
427
428

(defun register-directory (dir)
429
  (pushnew dir (symbol-value (asym :*central-registry*))))
430

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
431
(defun load-asdf-system (&rest keys)
432
433
  (quietly
   (register-directory *asdf-directory*)
434
   (register-directory *uiop-directory*)
435
436
   (apply (asym :oos) (asym :load-op) :asdf keys)))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
437
(defun call-with-asdf-conditions (thunk &optional verbose)
438
  (declare (ignorable verbose))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
439
  (handler-bind (#+(and ecl (not ecl-bytecmp))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
440
441
                 ((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
442
443
444
                   #'muffle-warning)
                 #+mkcl
                 ((or compiler:compiler-note) #'muffle-warning)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
445
446
447
                 #+sbcl
                 ((or sb-c::simple-compiler-note sb-kernel:redefinition-warning)
                   #'muffle-warning)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
448
449
450
451
452
453
454
455
456
457
458
459
460
461
                 #-(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))

462
(defun compile-asdf (&optional tag (verbose nil) upgradep)
463
464
465
466
  (let* ((alisp (asdf-lisp tag))
         (afasl (asdf-fasl tag))
         (tmp (make-pathname :name "asdf-tmp" :defaults afasl)))
    (ensure-directories-exist afasl)
467
    (multiple-value-bind (result warnings-p failure-p)
468
        (compile-file alisp :output-file tmp :verbose verbose :print verbose)
469
470
471
472
473
474
      (flet ((bad (key)
               (when result (ignore-errors (delete-file result)))
               key)
             (good (key)
               (when (probe-file afasl) (delete-file afasl))
               (rename-file tmp afasl)
475
               key))
476
        (cond
477
478
479
480
481
482
          ((null result)
           (bad :no-output))
          (failure-p
           (or
            #+clisp (good :expected-full-warnings)
            (bad :unexpected-full-warnings)))
483
484
          (warnings-p
           (or
485
486
            ;; CLISP has full warnings for method redefinition in eval-when.
            ;; CMUCL: ?
487
488
            ;; 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 (?)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
489
            #+(or clasp clisp cmu ecl scl xcl) (good :expected-style-warnings)
490
            (and upgradep (good :unexpected-style-warnings))
491
            (bad :unexpected-style-warnings)))
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
          (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
       (compile-asdf tag)))))

(defun compile-asdf-script ()
  (with-test ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
509
    (ecase (with-asdf-conditions () (maybe-compile-asdf))
510
511
512
513
      (:not-found
       (leave-test "Testsuite failed: unable to find ASDF source" 3))
      (:previously-compiled
       (leave-test "Reusing previously-compiled ASDF" 0))
514
515
516
517
518
519
520
      (:no-output
       (leave-test "Testsuite failed: ASDF compilation failed without output" 1))
      (:unexpected-full-warnings
       (leave-test "Testsuite failed: ASDF compiled with unexpected full warnings" 1))
      (:expected-full-warnings
       (leave-test "ASDF compiled with full warnings, ignored for your implementation" 0))
      (:unexpected-style-warnings
521
       (leave-test "Testsuite failed: ASDF compiled with unexpected warnings" 1))
522
523
      (:expected-style-warnings
       (leave-test "ASDF compiled with style-warnings, ignored for your implementation" 0))
524
525
526
      (:success
       (leave-test "ASDF compiled cleanly" 0)))))

527
(defun compile-load-asdf (&optional tag upgradep)
528
529
  ;; emulate the way asdf upgrades itself: load source, compile, load fasl.
  (load-asdf-lisp tag)
530
  (let ((results (compile-asdf tag nil upgradep)))
531
532
    (ecase results
      ((:no-output :unexpected-full-warnings :unexpected-style-warnings)
533
534
535
536
537
538
539
540
         (warn "ASDF compiled with ~S" results)
         (unless (and upgradep (eq results :unexpected-style-warnings))
           (leave-test "failed to compile ASDF" 1)))
      ((:expected-full-warnings :expected-style-warnings :success)))
    (load-asdf-fasl tag)))

(defun compile-load-asdf-upgrade (&optional tag)
  (compile-load-asdf tag t))
541
542
543
544
545
546
547
548

;;; 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)))
549

550
551
(defun get-asdf-version ()
  (when (find-package :asdf)
552
553
554
555
556
557
    (or (symbol-value (find-symbol (string :*asdf-version*) :asdf))
        (let ((ver (symbol-value (find-symbol (string :*asdf-revision*) :asdf))))
          (etypecase ver
            (string ver)
            (cons (format nil "~{~D~^.~}" ver))
            (null "1.0"))))))
558

559
(defun output-location (&rest sublocation)
560
  (list* *asdf-directory* "build/fasls" :implementation sublocation))
561
562
563
564
565
566
567
568
569
570
571
(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)))
572
573

(defun clean-asdf-system ()
574
  ;; If compiled by an antique ASDFs without output translations:
575
576
577
578
579
  (flet ((d (x) (acall :delete-file-if-exists x)))
    (let ((asdf-fasl (compile-file-pathname (asdf-lisp))))
      (d asdf-fasl)
      (d (acall :apply-output-translations asdf-fasl))
      (d (asdf-fasl)))))
580
581
582
583

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

585
586
587
588
589
(defun hash-table-alist (h)
  (loop for k being the hash-keys of h using (hash-value v) collect (cons k v)))

(defun registry ()
  (let ((sr (asymval :*source-registry*)))
590
    (when sr (sort (hash-table-alist sr) 'string< :key 'car))))
591

592
(defun configure-asdf ()
593
594
595
  (format t "Configuring ASDF~%")
  (when (asym :getenvp)
    (format t "Enabling debugging~%")
596
    (setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST"))))
597
598
599
600
  (when *trace-symbols*
    (format t "Tracing~{ ~A~}~%" *trace-symbols*)
    (eval `(trace ,@(loop :for s :in *trace-symbols* :collect (asym s)))))
  (when (asym :initialize-source-registry)
601
602
    (acall :initialize-source-registry
           `(:source-registry :ignore-inherited-configuration)))
603
  (when (asym :initialize-output-translations)
604
605
    (acall :initialize-output-translations
           `(:output-translations
606
607
             (,(acall :wilden *asdf-directory*) ,(acall :wilden (resolve-output "asdf/")))
             (t ,(acall :wilden (resolve-output "root")))
608
             :ignore-inherited-configuration)))
609
  (when (asym :*central-registry*)
610
    (set (asym :*central-registry*) `(,*test-directory*)))
611
  (format t "Being a bit verbose~%")
612
613
  (when (asym :*asdf-verbose*) (setf (asymval :*asdf-verbose*) t))
  (when (asym :*verbose-out*) (setf (asymval :*verbose-out*) *standard-output*))
614
  (when (and (asym :locate-system) (asym :pathname-directory-pathname) (asym :pathname-equal))
615
    (format t "Comparing directories~%")
616
617
618
619
620
621
622
623
    (acall :call-with-asdf-cache
             #'(lambda ()
                 (let ((x (acall :pathname-directory-pathname (nth-value 2 (acall :locate-system :test-asdf)))))
                   (assert-pathname-equal-helper ;; not always EQUAL (!)
                    '*test-directory* *test-directory*
                    '(:pathname-directory-pathname (nth-value 2 (:locate-system :test-asdf))) x)
                   (unless (equal *test-directory* x)
                     (format t "Interestingly, while *test-directory* has components~% ~S~%~
624
                 ASDF finds the ASDs in~% ~S~%Using the latter.~%"
625
626
627
                             (pathname-components *test-directory*)
                             (pathname-components x)))
                   (setf *test-directory* x)))))
628
629
630
  t)

(defun frob-packages ()
631
632
  (format t "Frob packages~%")
  (use-package :asdf :asdf-test)
633
  (when (find-package :uiop) (use-package :uiop :asdf-test))
634
  (when (find-package :asdf/cache) (use-package :asdf/cache :asdf-test))
635
  (setf *package* (find-package :asdf-test))
636
  t)
637

638
639
(defun load-asdf-lisp-and-test-uiop (&optional tag)
  (load-asdf-lisp tag)
640
641
642
643
  (unless (and (member :asdf *features*)
               (or (member :asdf3 *features*)
                   (and (member :asdf2 *features*) (acall :version-satisfies (acall :asdf-version) "2.11.4"))))
    (leave-test "UIOP will break ASDF < 2.011.4 - skipping test." 0))
644
645
646
647
  (configure-asdf)
  (register-directory *asdf-directory*)
  (register-directory *uiop-directory*)
  (register-directory *test-directory*)
648
649
  (quietly
   (acall :oos (asym :load-op) :uiop))
650
651
  (acall :oos (asym :load-op) :test-module-depend))

652
653
(defun load-asdf (&optional tag)
  (load-asdf-fasl tag)
654
  (configure-asdf))
655

656
657
(defun debug-asdf ()
  (setf *debug-asdf* t)
658
  (setf *quit-when-done* nil)
659
660
  (setf *package* (find-package :asdf-test)))

661
662
(defun just-load-asdf-fasl () (load-asdf-fasl))

663
;; Actual scripts rely on this function:
664
(defun common-lisp-user::load-asdf () (load-asdf))
665

666
667
668
(setf *package* (find-package :asdf-test))

(defmacro def-test-system (name &rest rest)
669
670
671
672
673
674
675
676
677
  (etypecase name
    (symbol
     `(apply (asym :register-system-definition) ',name
             :pathname ,*test-directory*
             :source-file nil ',rest))
    (string
     `(apply (asym :register-system-definition) ,name
             :pathname ,*test-directory*
             :source-file nil ',rest))))
678

679
(defun in-plan-p (plan x) (member x (acall :plan-actions plan) :key (asym :action-path) :test 'equal))
680

681
682
(defmacro test-load-systems (&rest x)
  `(do-test-load-systems ',x))
683

684
685
686
687
688
689
(defun do-test-load-systems (systems)
  (load-asdf-lisp)
  (dolist (sys systems)
    (format t "~&Trying to load ~A~%" sys)
    (acall :load-system sys))
  (format t "~&Done!~%"))
690

691
692
693
694
695
696
697
698
699
700
701
702
703
(defun test-upgrade (old-method new-method tag) ;; called by run-test
  (with-test ()
    (verbose t nil)
    (when old-method
      (cond
        ((string-equal tag "REQUIRE")
         (format t "Requiring some previous ASDF ~A~%" tag)
         (ignore-errors (funcall 'require "asdf"))
         (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)))
        (t
         (format t "Loading old asdf ~A via ~A~%" tag old-method)
704
         (acall (list old-method :asdf-test) tag))))
705
706
    (when (find-package :asdf)
      (configure-asdf))
707
708
709
710
    (when (and (null old-method) (eq 'load-asdf-fasl new-method) (not (probe-file (asdf-fasl))))
      (if (ignore-errors (funcall 'require "asdf") t)
          (leave-test "Your failed to compile ASDF before your run (test-upgrade ()'load-asdf-fasl ...)"  1)
          (leave-test "Your Lisp doesn't provide ASDF. Skipping (test-upgrade ()'load-asdf-fasl ...)"  0)))
711
    (format t "Now loading new asdf via method ~A~%" new-method)
712
    (acall (list new-method :asdf-test))
713
714
    (format t "Testing it~%")
    (register-directory *test-directory*)
715
    (load-test-system :test-asdf/all)
716
717
    (assert (asymval '#:*file1* :test-package))
    (assert (asymval '#:*file3* :test-package))))
718

719
720
721
722
723
724
(defun join-namestrings (namestrings)
  (with-output-to-string (s)
    (loop :with separator = (acall :inter-directory-separator)
          :for (n . morep) :on namestrings
          :do (format s "~A~@[~C~]" n (and morep separator)))))

725
726
727
728
;; 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
729
730
731
 la load-asdf common-lisp-user::la load-asdf
 ll load-asdf-lisp
 v verbose)
732

733
734
735
#| 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,
736
 that you should load in your asdf/plan by inserting an (uiop-debug) form in it.
737

738
739
740
741
 (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
))
|#