Commit 5a8eaccd authored by Robert Goldman's avatar Robert Goldman

Tests for loop check in ASD search.

Note that this loop check is problematic: if the bug appears and is not
fixed by the patch, this test will go away forever.
parent 7647ca49
(defsystem :loop
:components ((:file "loop")))
;;; -*- 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))))
(assert-equal (list "loop")
(let ((asds nil))
(declare (special asds))
(asdf/source-registry:collect-sub*directories-asd-files
"/Users/rpg/Downloads/asdf-loop\ 2/"
: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))
(initialize-source-registry
`(:source-registry (:tree ,scratch-dir) :ignore-inherited-configuration))
(assert (asdf:find-system :loop)))
;; clean up
(uiop:run-program (format nil "rm -r ~a" scratch-dir))))
(exit-lisp 0)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment