script-support.lisp 30.1 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 #:does-not-signal #: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
   #:reset-session #:reset-session-visited))
36

37
(in-package :asdf-test)
38

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

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

46
#+clasp
47 48
(unless (assoc "script" si:*load-hooks* :test #'equal)
  (push (cons "script" 'si:load-source) si:*load-hooks*))
49

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

(defvar *debug-asdf* nil)
58
(defvar *quit-when-done* t)
59

60 61 62
(defun verbose (&optional (verbose t) (print verbose))
  (setf *load-verbose* verbose *compile-verbose* verbose)
  (setf *load-print* print *compile-print* print))
63 64 65

(verbose nil)

66 67
;;; Minimal compatibility layer
(eval-when (:compile-toplevel :load-toplevel :execute)
68 69 70 71 72
  #+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.
73
  #+cmucl (setf ext:*gc-verbose* nil)
74
  #+gcl
75
  (si::use-fast-links nil)
76
  #+lispworks
77
  (setf system:*stack-overflow-behaviour* :warn))
78

79
#+genera
80 81
(unless (fboundp 'ensure-directories-exist)
  (defun ensure-directories-exist (path)
82
    #+genera (fs:create-directories-recursively (pathname path))))
83 84

;;; Survival utilities
85
(defun asym (name &optional package errorp)
86 87 88 89 90 91
  (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)))))
92
(defun acall (name &rest args)
93 94 95
  (apply (apply 'asym (if (consp name) name (list name))) args))
(defun asymval (name &optional package)
  (symbol-value (asym name package)))
96
(defsetf asymval (name &optional package) (new-value)
97 98 99 100 101
  (let ((sym (gensym "SYM")))
    `(let ((,sym (asym ,name ,package)))
       (if ,sym
           (setf (symbol-value ,sym) ,new-value)
           (error "NIHIL EX NIHILO")))))
102

103
(defun finish-outputs* ()
104 105 106
  (loop :for s :in (list *standard-output* *error-output* *trace-output* *debug-io*)
        :do (finish-output s)))
(defun redirect-outputs ()
107
  (finish-outputs*)
108 109
  (setf *error-output* *standard-output*
        *trace-output* *standard-output*))
110

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

113 114 115 116 117 118 119 120
;;; 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)))
121
(defmacro signals (condition sexp &aux (x (gensym)))
122 123 124 125 126
  `(progn
     (format *error-output* "~&Checking whether ~S signals ~S~%" ',sexp ',condition)
     (finish-output *error-output*)
     (handler-case
         ,sexp
127 128 129
       (,condition (,x)
         (format *error-output* "~&Received signal ~S~%" ,x)
         (finish-output *error-output*)
130
         ,x)
131 132
       (:no-error (&rest ,x)
         (error "Expression ~S fails to raise condition ~S, instead returning~{ ~S~}"
133 134 135 136 137 138 139 140 141 142 143 144
                ',sexp ',condition ,x)))))
(defmacro does-not-signal (condition sexp &aux (x (gensym)))
  `(progn
     (format *error-output* "~&Checking that ~S does NOT signal ~S~%" ',sexp ',condition)
     (finish-output *error-output*)
     (handler-case
         ,sexp
       (,condition (,x)
         (error "~&Condition signaled: ~S~%" ,x))
       (:no-error (&rest ,x)
         t))))
(defmacro errors (condition sexp &aux (x (gensym)))
145 146 147
  `(progn
     (format *error-output* "~&Checking whether ~S signals error ~S~%" ',sexp ',condition)
     (finish-output *error-output*)
148 149 150
     (let ((,x (nth-value 1 (ignore-errors ,sexp))))
       (assert-equal ',condition (type-of ,x))
       ,x)))
151 152 153 154 155 156 157 158 159 160
(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)))


161

162
;;; Helpful for debugging
163 164 165 166 167 168 169 170 171 172 173 174 175
(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)
176
     (format t "~S and~%~S both evaluate to same path:~%  ~S~%" qx qy x))
177 178 179
    #+mkcl
    ((acall :pathname-equal x y)
     (format t "~S and ~S evaluate to functionaly equivalent paths, respectively:~%  ~S~%and~%  ~S~%" qx qy x y))
180
    ((acall :pathname-equal x y)
181
     (warn "These two expressions yield pathname-equal yet not equal path~%~
182 183 184 185
        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)))
186
    ;; accept equalp namestrings, to account for case-independent filesystems
187
    ((equalp (and x (namestring x)) (and y (namestring y)))
188 189 190 191 192
     (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)))
193
    (t
194
     (error "These two expressions yield paths that are not equal in any way:~%~
195 196 197 198
        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)))))
199 200
(defmacro assert-pathname-equal (x y)
  `(assert-pathname-equal-helper ',x ,x ',y ,y))
201
(defun assert-length-equal-helper (qx x qy y)
202
  (unless (= (length x) (length y))
203
    (error "These two expressions yield sequences of unequal length~%
204 205
        The first, ~S, has value ~S of length ~S~%
        The other, ~S, has value ~S of length ~S~%"
206
           qx x (length x) qy y (length y))))
207 208 209 210 211 212 213 214 215 216 217 218
(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.
219 220 221
;; 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.
222
(defparameter *test-directory*
223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248
  ;; 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))))
249
           #+mkcl (#.(or (find-symbol "GETENV" :si) (find-symbol "GETENV" :mk-ext)) x)
250 251 252 253 254 255 256 257
           #+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*))))))

258 259 260
(defun make-sub-pathname (&rest keys &key defaults &allow-other-keys)
  (merge-pathnames (apply 'make-pathname keys) defaults))
(defparameter *asdf-directory*
261
  (truename (make-sub-pathname :directory '(:relative :back) :defaults *test-directory*)))
262
(defparameter *uiop-directory*
263
  (truename (make-sub-pathname :directory '(:relative "uiop") :defaults *asdf-directory*)))
264
(defparameter *build-directory*
265
  (make-sub-pathname :directory '(:relative "build") :defaults *asdf-directory*))
266 267 268 269 270 271
(defparameter *implementation*
  (or #+allegro
      (ecase excl:*current-case-mode*
        (:case-sensitive-lower :mlisp)
        (:case-insensitive-upper :alisp))
      #+armedbear :abcl
272
      #+ecl (or #+ecl-bytecmp :ecl_bytecodes :ecl)
273
      #+clisp :clisp
274
      #+clasp :clasp
275
      #+clozure :ccl
276
      #+cmucl :cmucl
277 278 279 280 281 282 283 284 285
      #+corman :cormanlisp
      #+digitool :mcl
      #+gcl :gcl
      #+lispworks :lispworks
      #+mkcl :mkcl
      #+sbcl :sbcl
      #+scl :scl
      #+xcl :xcl))
(defparameter *early-fasl-directory*
286
  (make-sub-pathname :directory `(:relative "fasls" ,(string-downcase *implementation*))
287 288 289 290 291 292 293
                     :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 ()
294
  (make-sub-pathname :directory '(:relative "contrib") :name "debug" :type "lisp" :defaults *uiop-directory*))
295
(defun early-compile-file-pathname (file)
296
  (compile-file-pathname
297 298 299
   (make-pathname :name (pathname-name file) :type "lisp" :defaults *early-fasl-directory*)))
(defun asdf-fasl (&optional tag)
  (early-compile-file-pathname (asdf-lisp tag)))
300

301 302
;;; Test helper functions

303
(load (debug-lisp))
304
(verbose t nil)
305

306 307 308 309 310 311
(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)
312
    (error "These two expressions fail comparison with ~S:~% ~
313 314 315 316 317
            ~S evaluates to ~S~% ~S evaluates to ~S~%"
            op qx x qy y)))

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

319 320 321 322 323 324 325 326
(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)))

327
(defun touch-file (file &key offset timestamp in-filesystem)
328 329
  (let* ((base (or timestamp (get-universal-time)))
         (stamp (if offset (+ base offset) base)))
Robert Goldman's avatar
Robert Goldman committed
330
    (if in-filesystem
331
        (multiple-value-bind (sec min hr day month year)
332
            (decode-universal-time stamp)
333
          (acall :run-program
334 335
                 `("touch" "-t" ,(format nil "~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D"
                                         year month day hr min sec)
336
                           ,(acall :native-namestring file)))
Robert Goldman's avatar
Robert Goldman committed
337 338 339
          (assert-equal (file-write-date file) stamp))
      ;; else
      (progn
340 341
        (unless (asymval :*asdf-session*)
          (error "Trying to use the ASDF session cache in TOUCH-FILE, but it is not initialized."))
Robert Goldman's avatar
Robert Goldman committed
342 343
        (acall :register-file-stamp file stamp)))))

344
(defun mark-file-deleted (file)
345
  (unless (asymval :*asdf-session*) (error "Y U NO use asdf session?"))
346
  (acall :register-file-stamp (acall :normalize-namestring file) nil))
347

348 349 350 351
(defun hash-table->alist (table)
  (loop :for key :being :the :hash-keys :of table :using (:hash-value value)
    :collect (cons key value)))

352
(defun exit-lisp (&optional (code 0)) ;; Simplified from asdf/image:quit
353
  (finish-outputs*)
354 355
  #+(or abcl xcl) (ext:quit :status code)
  #+allegro (excl:exit code :quiet t)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
356
  #+(or clasp ecl) (si:quit code)
357 358 359
  #+clisp (ext:quit code)
  #+clozure (ccl:quit code)
  #+cormanlisp (win32:exitprocess code)
360
  #+(or cmucl scl) (unix:unix-exit code)
361
  #+gcl (system:quit code)
362 363 364 365
  #+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
366
  #+sbcl #.(let ((exit (find-symbol "EXIT" :sb-ext))
367 368 369 370
                 (quit* (find-symbol "QUIT" :sb-ext)))
             (cond
               (exit `(,exit :code code :abort t))
               (quit* `(,quit* :unix-status code :recklessly-p t))))
371
  #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
372
  (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code))
373 374


375
(defun leave-test (message return)
376 377
  "Print MESSAGE and throw RETURN, which should be a POSIX error
code (an integer, 0 for success), up as exit code."
378
  (finish-outputs*)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
379 380 381
  (fresh-line *error-output*)
  (when message
    (format *error-output* message)
382
    (fresh-line *error-output*))
383
  (finish-outputs*)
384
  (throw :asdf-test-done return))
385

386
(defmacro with-test ((&optional) &body body)
387
  `(call-with-test (lambda () ,@body)))
388

389 390 391
(deftype test-fatal-condition ()
    `(and serious-condition #+ccl (not ccl:process-reset)))

392
(defun call-with-test (thunk)
393 394 395
  "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."
396
  (redirect-outputs)
397
  (let ((result
398 399
         (catch :asdf-test-done
           (handler-bind
400
               ((test-fatal-condition
401 402 403 404 405 406
                 (lambda (c)
                   (ignore-errors
                     (format *error-output* "~&TEST ABORTED: ~A~&" c))
                   (finish-outputs*)
                   (unless *debug-asdf*
                     (ignore-errors
407
                       (format *error-output* "~&Backtrace:~%")
408 409 410
                       (acall :print-condition-backtrace
                              c :count 69 :stream *error-output*))
                     (leave-test "Script failed" 1)))))
411
             (funcall (or (asym :call-with-asdf-session) 'funcall) thunk)
412
             (leave-test "Script succeeded" 0)))))
413
    (when *quit-when-done*
414
      (exit-lisp result))))
415 416 417 418 419 420 421

;;; These are used by the upgrade tests

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

(defun call-quietly (thunk)
422
  #-allegro
423
  (handler-bind (#+sbcl (sb-kernel:redefinition-warning #'muffle-warning))
424 425 426
    (funcall thunk))
  #+allegro
  (excl:without-redefinition-warnings
427
   (funcall thunk)))
428

429 430 431 432
(defun interactive-test (&optional files)
  (verbose t nil)
  (loop :for file :in files :do
    (load (string-downcase file)))
433
  (setf *package* (some 'find-package '(:asdf :uiop :asdf/utility :asdf/package :asdf-test)))
434 435
  (load "contrib/debug.lisp"))

436 437 438 439 440 441
(defun run-test-script (file)
  (with-test ()
    (let ((name (string file)))
      (format t "Running ~A with ~A~%" name (acall :implementation-identifier))
      (load name))))

442
(defun load-asdf-lisp (&optional tag)
443
  (quietly (load (asdf-lisp tag) :verbose *load-verbose* :print *load-print*)))
444

445 446
(defun load-asdf-fasl (&optional tag)
  (quietly (load (asdf-fasl tag))))
447 448

(defun register-directory (dir)
449
  (pushnew dir (symbol-value (asym :*central-registry*))))
450

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
451
(defun load-asdf-system (&rest keys)
452 453
  (quietly
   (register-directory *asdf-directory*)
454
   (register-directory *uiop-directory*)
455 456
   (apply (asym :oos) (asym :load-op) :asdf keys)))

457
(defun call-with-asdf-conditions (thunk &optional verbose)
458
  (declare (ignorable verbose))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
459
  (handler-bind (#+(and ecl (not ecl-bytecmp))
460 461
                 ((or c::compiler-note c::compiler-debug-note
                      c::compiler-warning) ;; ECL emits more serious warnings than it should.
462 463 464
                   #'muffle-warning)
                 #+mkcl
                 ((or compiler:compiler-note) #'muffle-warning)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
465 466 467
                 #+sbcl
                 ((or sb-c::simple-compiler-note sb-kernel:redefinition-warning)
                   #'muffle-warning)
468
                 #-(or cmucl scl)
469 470 471 472 473 474 475 476 477 478 479 480 481
                 ;; 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))

482
(defun compile-asdf (&optional tag (verbose nil) upgradep)
483 484 485 486
  (let* ((alisp (asdf-lisp tag))
         (afasl (asdf-fasl tag))
         (tmp (make-pathname :name "asdf-tmp" :defaults afasl)))
    (ensure-directories-exist afasl)
487
    (multiple-value-bind (result warnings-p failure-p)
488
        (compile-file alisp :output-file tmp :verbose verbose :print verbose)
489 490 491 492 493 494
      (flet ((bad (key)
               (when result (ignore-errors (delete-file result)))
               key)
             (good (key)
               (when (probe-file afasl) (delete-file afasl))
               (rename-file tmp afasl)
495
               key))
496
        (cond
497 498 499 500 501 502
          ((null result)
           (bad :no-output))
          (failure-p
           (or
            #+clisp (good :expected-full-warnings)
            (bad :unexpected-full-warnings)))
503 504
          (warnings-p
           (or
505 506
            ;; CLISP has full warnings for method redefinition in eval-when.
            ;; CMUCL: ?
507 508
            ;; 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 (?)
509
            #+(or clasp clisp cmucl ecl scl xcl) (good :expected-style-warnings)
510
            (and upgradep (good :unexpected-style-warnings))
511
            (bad :unexpected-style-warnings)))
512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528
          (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 ()
529
    (ecase (with-asdf-conditions (t) (maybe-compile-asdf))
530 531 532 533
      (:not-found
       (leave-test "Testsuite failed: unable to find ASDF source" 3))
      (:previously-compiled
       (leave-test "Reusing previously-compiled ASDF" 0))
534 535 536 537 538 539 540
      (: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
541
       (leave-test "Testsuite failed: ASDF compiled with unexpected warnings" 1))
542 543
      (:expected-style-warnings
       (leave-test "ASDF compiled with style-warnings, ignored for your implementation" 0))
544 545 546
      (:success
       (leave-test "ASDF compiled cleanly" 0)))))

547
(defun compile-load-asdf (&optional tag upgradep)
548 549
  ;; emulate the way asdf upgrades itself: load source, compile, load fasl.
  (load-asdf-lisp tag)
550
  (let ((results (compile-asdf tag nil upgradep)))
551 552
    (ecase results
      ((:no-output :unexpected-full-warnings :unexpected-style-warnings)
553 554 555 556 557 558 559 560
         (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))
561 562 563 564 565 566 567 568

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

570 571
(defun get-asdf-version ()
  (when (find-package :asdf)
572 573 574 575 576 577
    (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"))))))
578

579
(defun output-location (&rest sublocation)
580
  (list* *asdf-directory* "build/fasls" :implementation sublocation))
581 582 583 584 585 586 587 588 589 590 591
(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)))
592 593

(defun clean-asdf-system ()
594
  ;; If compiled by an antique ASDFs without output translations:
595 596 597 598 599
  (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)))))
600 601 602 603

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

605 606 607 608 609
(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*)))
610
    (when sr (sort (hash-table-alist sr) 'string< :key 'car))))
611

612
(defun configure-asdf ()
613 614 615
  (format t "Configuring ASDF~%")
  (when (asym :getenvp)
    (format t "Enabling debugging~%")
616
    (setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST"))))
617 618 619 620
  (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)
621 622
    (acall :initialize-source-registry
           `(:source-registry :ignore-inherited-configuration)))
623
  (when (asym :initialize-output-translations)
624 625
    (acall :initialize-output-translations
           `(:output-translations
626 627
             (,(acall :wilden *asdf-directory*) ,(acall :wilden (resolve-output "asdf/")))
             (t ,(acall :wilden (resolve-output "root")))
628
             :ignore-inherited-configuration)))
629
  (when (asym :*central-registry*)
630
    (set (asym :*central-registry*) `(,*test-directory*)))
631
  (format t "Being a bit verbose~%")
632 633
  (when (asym :*asdf-verbose*) (setf (asymval :*asdf-verbose*) t))
  (when (asym :*verbose-out*) (setf (asymval :*verbose-out*) *standard-output*))
634
  (funcall
635
   ;; Old versions of ASDF don't always use with-asdf-session in locate system, but need it.
636
   ;; So we do it for them for the sake of testing upgrade from these old versions.
637 638
   ;; Yet older versions of ASDF don't even have this session cache, so then we don't.
   (or (asym :call-with-asdf-session) (asym :call-with-asdf-cache) 'funcall)
639 640 641 642 643 644 645 646 647
   (lambda ()
     (when (and (asym :locate-system) (asym :pathname-directory-pathname) (asym :pathname-equal))
       (format t "Comparing directories~%")
       (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~%~
648
                 ASDF finds the ASDs in~% ~S~%Using the latter.~%"
649 650 651
                   (pathname-components *test-directory*)
                   (pathname-components x)))
         (setf *test-directory* x)))))
652 653 654
  t)

(defun frob-packages ()
655 656
  (format t "Frob packages~%")
  (use-package :asdf :asdf-test)
657
  (when (find-package :uiop) (use-package :uiop :asdf-test))
658
  (when (find-package :asdf/session) (use-package :asdf/session :asdf-test))
659
  (setf *package* (find-package :asdf-test))
660
  t)
661

662 663
(defun load-asdf-lisp-and-test-uiop (&optional tag)
  (load-asdf-lisp tag)
664 665 666 667
  (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))
668 669 670 671
  (configure-asdf)
  (register-directory *asdf-directory*)
  (register-directory *uiop-directory*)
  (register-directory *test-directory*)
672 673
  (quietly
   (acall :oos (asym :load-op) :uiop))
674 675
  (acall :oos (asym :load-op) :test-module-depend))

676 677
(defun load-asdf (&optional tag)
  (load-asdf-fasl tag)
678
  (configure-asdf))
679

680 681
(defun debug-asdf ()
  (setf *debug-asdf* t)
682
  (setf *quit-when-done* nil)
683
  (frob-packages))
684

685 686
(defun just-load-asdf-fasl () (load-asdf-fasl))

687
;; Actual scripts rely on this function:
688
(defun common-lisp-user::load-asdf () (load-asdf))
689

690 691 692
(setf *package* (find-package :asdf-test))

(defmacro def-test-system (name &rest rest)
693 694 695 696 697 698 699 700 701
  (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))))
702

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

705 706
(defmacro test-load-systems (&rest x)
  `(do-test-load-systems ',x))
707

708 709 710 711 712 713
(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!~%"))
714

715 716 717 718 719 720 721 722 723 724 725 726 727
(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)
728
         (acall (list old-method :asdf-test) tag))))
729 730
    (when (find-package :asdf)
      (configure-asdf))
731 732 733 734
    (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)))
735
    (format t "Now loading new asdf via method ~A~%" new-method)
736
    (acall (list new-method :asdf-test))
737 738
    (format t "Testing it~%")
    (register-directory *test-directory*)
739
    (load-test-system :test-asdf/all)
740 741
    (assert (asymval '#:*file1* :test-package))
    (assert (asymval '#:*file3* :test-package))))
742

743
(defun join-namestrings (namestrings)
744 745 746 747 748 749 750 751
  (format nil (format nil "~~{~~A~~^~A~~}" (acall :inter-directory-separator)) namestrings))

(defun reset-session ()
  (set (asym :*asdf-session*) nil))

(defun reset-session-visited ()
  (clrhash (acall '#:visited-actions (asymval '#:*asdf-session*))))

752

753 754 755 756
;; 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
757 758 759
 la load-asdf common-lisp-user::la load-asdf
 ll load-asdf-lisp
 v verbose)
760

761 762 763
#| 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,
764
 that you should load in your asdf/plan by inserting an (uiop-debug) form in it.
765

766 767 768 769
 (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
))
|#