test-symlink-loop.script 3.31 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
;;; -*- Lisp -*-

;;;---------------------------------------------------------------------------
;;; This checks a fix to bug 1533766 where a search of the
;;; registry can be caused to loop forever if symlinks introduce a circularity
;;; into the file tree.
;;; ---------------------------------------------------------------------------
(in-package :asdf-test)
;; since symlinks only somewhat exist on Windows, we don't test there.
(when (uiop:os-windows-p)
  (exit-lisp 0))

(let ((scratch-dir (namestring (make-sub-pathname :directory '(:relative "looping-scratch")
                                                  :defaults *test-directory*))))
  (unwind-protect
       (progn
         ;; set up pathological directory structure
         (uiop:run-program (format nil "mkdir ~a" scratch-dir))
         (uiop:run-program (format nil "mkdir ~a/subdirs" scratch-dir))
         (uiop:run-program (format nil "mkdir ~a/subdirs/subdir" scratch-dir))
         (uiop:run-program (format nil "mkdir ~a/subdirs/subdir2" scratch-dir))
         (uiop:run-program (format nil "cd ~a/subdirs/subdir ; ln -s .. ln-subdir"
                                   scratch-dir))
         (uiop:run-program (format nil "cd ~a/subdirs/subdir2 ; ln -s .. ln-subdir"
                                   scratch-dir))
         (uiop:copy-file (format nil "~a" (namestring (make-sub-pathname :name "loop"
                                                                         :type "asd"
                                                                         :defaults *test-directory*)))
                         (format nil "~a" (namestring (make-sub-pathname :name "loop"
                                                                         :type "asd"
                                                                         :defaults scratch-dir))))
Robert Goldman's avatar
Robert Goldman committed
32
         (DBG "Testing search for asdf system definitions.")
33 34 35 36
         (assert-equal (list "loop")
                       (let ((asds nil))
                         (declare (special asds))
                         (asdf/source-registry:collect-sub*directories-asd-files
37
                          scratch-dir
38 39 40 41 42 43 44 45 46 47 48 49 50
                          :collect
                          #'(lambda (asd)
                              (let* ((name (pathname-name asd))
                                     (name (if (typep asd 'logical-pathname)
                                               ;; logical pathnames are upper-case,
                                               ;; at least in the CLHS and on SBCL,
                                               ;; yet (coerce-name :foo) is lower-case.
                                               ;; won't work well with (load-system "Foo")
                                               ;; instead of (load-system 'foo)
                                               (string-downcase name)
                                               name)))
                                (push name asds))))
                         asds))
Robert Goldman's avatar
Robert Goldman committed
51
         (DBG "Resetting source registry.")
52 53
         (initialize-source-registry
          `(:source-registry (:tree ,scratch-dir) :ignore-inherited-configuration))
Robert Goldman's avatar
Robert Goldman committed
54
         (DBG "Looking for the LOOP system")
55 56
         (assert (asdf:find-system :loop)))
    ;; clean up
Robert Goldman's avatar
Robert Goldman committed
57
    (DBG "Cleaning up")
58 59
    (uiop:run-program (format nil "rm -r ~a" scratch-dir))))

Robert Goldman's avatar
Robert Goldman committed
60
(DBG "Exiting")
61
(exit-lisp 0)